diff options
| author | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2010-09-19 18:19:39 +0000 |
|---|---|---|
| committer | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2010-09-19 18:19:39 +0000 |
| commit | e56043cd2c207982e812ce6fcecb7353dea58363 (patch) | |
| tree | 01a6f37ad5a9ae6b18bdc20f052b04e19b4255c0 /gcc/fortran | |
| parent | 2e02a1a4548f2ee1ea519c88e68b20621ad16fcc (diff) | |
| download | gcc-e56043cd2c207982e812ce6fcecb7353dea58363.tar.gz | |
2010-09-19 Basile Starynkevitch <basile@starynkevitch.net>
MELT branch merged with trunk rev 164348, with some improvements
in gcc/melt-runtime.[ch]
2010-09-19 Basile Starynkevitch <basile@starynkevitch.net>
[[merged with trunk rev.164348, so improved MELT runtime!]]
* gcc/melt-runtime.h: improved comments.
(melt_debug_garbcoll, melt_debuggc_eprintf): Moved from melt-runtime.c.
(melt_obmag_string): New declaration.
(struct meltobject_st, struct meltclosure_st, struct
meltroutine_st, struct meltmixbigint_st, struct meltstring_st):
using GTY variable_size and @@MELTGTY@@ comment.
(melt_mark_special): added debug print.
* gcc/melt-runtime.c: Improved comments.
Include bversion.h, realmpfr.h, gimple-pretty-print.h.
(ggc_force_collect) Declared external.
(melt_forward_counter): Added.
(melt_obmag_string): New function.
(melt_alptr_1, melt_alptr_2, melt_break_alptr_1_at)
(melt_break_alptr_2_at, melt_break_alptr_1,melt_break_alptr_1)
(melt_allocate_young_gc_zone, melt_free_young_gc_zone): New.
(delete_special, meltgc_make_special): Improved debug printf and
use melt_break_alptr_1...
(ggc_alloc_*) macros defined for backport to GCC 4.5
(melt_forwarded_copy): Don't clear the new destination zone in old
GGC heap.
(meltgc_add_out_raw_len): Use ggc_alloc_atomic.
(meltgc_raw_new_mappointers, meltgc_raw_put_mappointers)
(meltgc_raw_remove_mappointers): Corrected length argument to
ggc_alloc_cleared_vec_entrypointermelt_st.
(melt_really_initialize): Call melt_allocate_young_gc_zone.
(melt_initialize): Set flag_plugin_added.
(melt_val2passflag): TODO_verify_loops only in GCC 4.5
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@164424 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/fortran')
72 files changed, 23393 insertions, 10300 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8af36683afa..966287d91a0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,3604 @@ +2010-09-16 Tobias Burnus <burnus@net-b.de> + + PR fortran/43665 + * trans-types.c (create_fn_spec): New function. + (gfc_get_function_type): Call it. + +2010-09-16 Jakub Jelinek <jakub@redhat.com> + + * gfortran.h (walk_code_fn_t, walk_expr_fn_t): New types. + (gfc_expr_walker, gfc_code_walker): New prototypes. + * frontend-passes.c (gfc_expr_walker, gfc_code_walker): New functions. + (WALK_SUBEXPR, WALK_SUBEXPR_TAIL, WALK_SUBCODE): Define. + (optimize_namespace): Use gfc_code_walker. + (optimize_code, optimize_expr): Rewritten as gfc_code_walker hooks. + (optimize_expr_0, optimize_code_node, + optimize_actual_arglist): Removed. + (optimize_assignment): Don't call optimize_expr_0. + +2010-09-16 Janus Weil <janus@gcc.gnu.org> + + PR fortran/45674 + * interface.c (compare_parameter): Create vtab for actual argument, + instead of formal (if needed). + +2010-09-15 Janus Weil <janus@gcc.gnu.org> + + PR fortran/45577 + * resolve.c (resolve_allocate_expr): Do default initialization via + EXEC_INIT_ASSIGN. + +2010-09-11 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * mathbuiltins.def: Do not defined huge_val built-in. + * trans-const.c (gfc_build_inf_or_huge): New function. + * trans-const.h (gfc_build_inf_or_huge): New prototype. + * f95-lang.c (gfc_init_builtin_functions): Don't defined + huge_val built-ins. + * trans-intrinsic.c (gfc_build_intrinsic_lib_fndecls): We don't + have functions of type (*) (void) anymore. + (gfc_conv_intrinsic_minmaxloc): Call gfc_build_inf_or_huge. + (gfc_conv_intrinsic_nearest): Call gfc_build_inf_or_huge instead + of generating a call to huge_val(). + +2010-09-11 Mikael Morin <mikael@gcc.gnu.org> + + * gfortran.h (gfc_expr): Remove inline_noncopying_intrinsic attribute. + * dependency.c (gfc_check_dependency): Don't depend on + expr's inline_noncopying_intrinsic_attribute. + * dependency.c (gfc_check_argument_var_dependency, + gfc_check_argument_dependency): Ditto. Recursively check dependency + as NOT_ELEMENTAL in the non-copying (=transpose) case. + * trans-intrinsic.c (gfc_conv_intrinsic_function): Ditto. + * resolve.c (find_noncopying_intrinsics): Remove. + (resolve_function, resolve_call): Remove call to + find_noncopying_intrinsics. + + * trans-array.c (gfc_conv_array_transpose): Remove. + (gfc_walk_subexpr): Make non-static. Move prototype... + * trans-array.h (gfc_walk_subexpr): ... here. + * trans-intrinsic.c (gfc_conv_intrinsic_function): Update transpose + handling. + (walk_inline_intrinsic_transpose, walk_inline_intrinsic_function, + gfc_inline_intrinsic_function_p): New. + (gfc_is_intrinsic_libcall): Return early in inline intrinsic case. + Remove transpose from the libcall list. + (gfc_walk_intrinsic_function): Special case inline intrinsic. + * trans.h (gfc_inline_intrinsic_function_p): New prototype. + +2010-09-10 Mikael Morin <mikael@gcc.gnu.org> + + * trans-expr.c (expr_is_variable): New function taking non-copying + intrinsic functions into account. + (gfc_trans_assignment_1): Use expr_is_variable. + +2010-09-10 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.c (gfc_conv_loop_setup): Access the shape along the + real array dimension instead of the scalarizer (loop) dimension. + +2010-09-10 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.c (gfc_conv_resolve_dependencies): Handle same-array + transposed references. + +2010-09-10 Tobias Burnus <burnus@net-b.de> + + PR fortran/45186 + * trans.h (build1_stat_loc, build2_stat_loc, build3_stat_loc, + build4_stat_loc): New inline functions. + (build1_loc, build2_loc, build3_loc, build4_loc): New macros. + (build1_v, build2_v, build3_v, build4_v): Use input_location + as locus. + * trans-array.c (gfc_trans_scalarized_loop_end, + gfc_conv_array_parameter): Replace build[1-4] by build[1-4]_loc. + * trans.c (gfc_build_addr_expr, gfc_build_array_ref, + gfc_finish_wrapped_block): Ditto. + * trans-decl.c (gfc_init_default_dt, init_intent_out_dt): Ditto. + * trans-expr.c (gfc_conv_missing_dummy, + gfc_trans_alloc_subarray_assign, gfc_trans_zero_assign): Ditto. + * trans-openmp.c (gfc_omp_clause_default_ctor, + gfc_trans_omp_critical, gfc_trans_omp_parallel, + gfc_trans_omp_parallel_do, gfc_trans_omp_parallel_sections, + gfc_trans_omp_parallel_workshare, gfc_trans_omp_sections + gfc_trans_omp_single, gfc_trans_omp_task, + gfc_trans_omp_workshare): Ditto. + +2010-09-09 Steven G. Kargl <kargl@gcc.gnu.org> + + * fortran/expr.c (check_inquiry): OPTIONAL attribute is not allowed + for dummy argument that appears in a specification statement. + +2010-09-09 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.c (gfc_get_array_ref_dim): New function. + (gfc_trans_create_temp_array): Reconstruct array + bounds from loop bounds. Use array bounds instead of loop bounds. + +2010-09-09 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.c (gfc_set_loop_bounds_from_array_spec): + Get the array dimension from the dim array. + +2010-09-09 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.c (gfc_trans_preloop_setup): Unconditionally use the + dim array to get the stride in the innermost loop. + +2010-09-09 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.c (gfc_trans_create_temp_array): Don't set dim array. + (gfc_conv_loop_setup, gfc_walk_function_expr): Set dim array. + * trans-intrinsic.c (gfc_walk_intrinsic_libfunc): Ditto. + +2010-09-09 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.c (gfc_trans_create_temp_array): Assert loop dimension + and info dimension are the same. Loop over loop dimension. + * trans-stmt.c (gfc_conv_elemental_dependencies): Set loop dimension + +2010-09-09 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.c (gfc_conv_array_transpose): Change generated descriptor + name + +2010-09-09 Tobias Burnus <burnus@net-b.de> + + PR fortran/43665 + * intrincic.texi (FGET, FGETC, FPUT, FPUTC, FSTAT, GETCWD, KILL, + STAT): Show also syntax for the function version. + * intrinsic.c (add_sym_1s_intent, add_sym_2s_intent, + add_sym_3s_intent): Remove function. + (add_sym_1s, add_sym_2s, add_sym_3s): Take always the intent + as argument. + (add_sym_2_intent): New function. + (add_functions): Set intent for functions which modify + the argument: fstat, fgetc, fget, hostnm, lstat, stat. Change + argument name of hostnm from "a" to "c" + (add_subroutines): Change add_sym_*s_intent to + add_sym_*s and add intent to the add_sym_*s calls. + +2010-09-08 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/38282 + * intrinsic.c (add_functions): Add B{G,L}{E,T}, DSHIFT{L,R}, + MASK{L,R}, MERGE_BITS and SHIFT{A,L,R}. + * gfortran.h: Define ISYM values for above intrinsics. + * intrinsic.h (gfc_check_bge_bgt_ble_blt, gfc_check_dshift, + gfc_check_mask, gfc_check_merge_bits, gfc_check_shift, + gfc_simplify_bge, gfc_simplify_bgt, gfc_simplify_ble, + gfc_simplify_blt, gfc_simplify_dshiftl, gfc_simplify_dshiftr, + gfc_simplify_lshift, gfc_simplify_maskl, gfc_simplify_maskr, + gfc_simplify_merge_bits, gfc_simplify_rshift, + gfc_simplify_shifta, gfc_simplify_shiftl, gfc_simplify_shiftr, + gfc_resolve_dshift, gfc_resolve_mask, gfc_resolve_merge_bits, + gfc_resolve_shift): New prototypes. + * iresolve.c (gfc_resolve_dshift, gfc_resolve_mask, + gfc_resolve_merge_bits, gfc_resolve_shift): New functions. + * check.c (gfc_check_bge_bgt_ble_blt, gfc_check_dshift, + gfc_check_mask, gfc_check_merge_bits, gfc_check_shift): New + functions. + * trans-intrinsic.c (gfc_conv_intrinsic_dshift, + gfc_conv_intrinsic_bitcomp, gfc_conv_intrinsic_shift, + gfc_conv_intrinsic_merge_bits, gfc_conv_intrinsic_mask): New + functions. + (gfc_conv_intrinsic_function): Call above static functions. + * intrinsic.texi: Document new intrinsics. + * simplify.c (gfc_simplify_bge, gfc_simplify_bgt, gfc_simplify_ble, + gfc_simplify_blt, gfc_simplify_dshiftl, gfc_simplify_dshiftr, + gfc_simplify_lshift, gfc_simplify_maskl, gfc_simplify_maskr, + gfc_simplify_merge_bits, gfc_simplify_rshift, + gfc_simplify_shifta, gfc_simplify_shiftl, gfc_simplify_shiftr): + New functions. + +2010-09-08 Jakub Jelinek <jakub@redhat.com> + + * frontend-passes.c (optimize_code_node): Walk block chain by default. + + PR fortran/45597 + * trans-openmp.c (gfc_trans_omp_do): Store exit/cycle labels on code + instead of code->block. + + PR fortran/45595 + * openmp.c (resolve_omp_do): Report not enough do loops for + collapse even if block->next is NULL. + +2010-09-07 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/45576 + * dependency.c (gfc_deb_compare_expr): Take missing optional + arguments into account. + +2010-09-08 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * trans.h (gfor_fndecl_clz128, gfor_fndecl_ctz128): Remove. + * trans-decl.c (gfor_fndecl_clz128, gfor_fndecl_ctz128): Remove. + (gfc_build_intrinsic_function_decls): Don't build the + gfor_fndecl_clz128 and gfor_fndecl_ctz128. + * trans-intrinsic.c (gfc_conv_intrinsic_leadz, + gfc_conv_intrinsic_trailz): Generate inline arithmetic instead + of calling clz128/ctz128 library functions. + +2010-09-07 Jan Hubicka <jh@suse.cz> + + * trans-expr.c (gfc_conv_initializer): Set STATIC flags for + initializers. + +2010-09-07 Tobias Burnus <burnus@net-b.de> + + PR fortran/45583 + * intrinsic.texi (COS): Remove superfluous "n". + +2010-09-07 Tobias Burnus <burnus@net-b.de> + + PR fortran/45186 + * trans-array.c (gfc_conv_descriptor_data_get, + gfc_conv_descriptor_data_set, gfc_conv_descriptor_data_addr, + gfc_conv_descriptor_offset, gfc_conv_descriptor_dtype, + gfc_conv_descriptor_dimension, gfc_conv_descriptor_stride, + gfc_conv_descriptor_lbound, gfc_conv_descriptor_ubound, + gfc_conv_shift_descriptor_lbound, + gfc_set_loop_bounds_from_array_spec, + gfc_trans_allocate_array_storage, gfc_trans_create_temp_array, + gfc_conv_array_transpose, gfc_get_iteration_count, + gfc_grow_array, gfc_trans_array_ctor_element, + gfc_trans_array_constructor_subarray, + gfc_trans_array_constructor_value, + constant_array_constructor_loop_size, gfc_trans_array_constructor, + gfc_set_vector_loop_bounds, gfc_trans_array_bound_check, + gfc_conv_array_index_offset, gfc_conv_scalarized_array_ref, + gfc_conv_array_ref, gfc_trans_preloop_setup, + gfc_trans_scalarized_loop_end, gfc_conv_ss_startstride, + gfc_conv_loop_setup, gfc_conv_array_extent_dim, + gfc_conv_descriptor_size, gfc_array_init_size, + gfc_array_allocate, gfc_array_deallocate, + gfc_trans_array_bounds, gfc_trans_auto_array_allocation, + gfc_trans_dummy_array_bias, gfc_get_dataptr_offset, + get_array_charlen, gfc_conv_expr_descriptor, + array_parameter_size, gfc_conv_array_parameter, + gfc_trans_dealloc_allocated, get_full_array_size, + duplicate_allocatable, + structure_alloc_comps): Change fold_build[0-9] to + fold_build[0-9]_loc. + (duplicate_allocatable, structure_alloc_comps, + gfc_duplicate_allocatable): Add space after function name. + +2010-09-07 Mikael Morin <mikael@gcc.gnu.org> + + * trans-stmt.c (gfc_trans_character_select): Be conversion-safe while + checking string length value. + * trans-intrinsic.c (gfc_conv_intrinsic_char): Build integer using + gfc_charlen_type_node type. + + PR fortran/45564 + * trans-intrinsic.c (gfc_conv_intrinsic_transfer): Convert string + length to gfc_charlen_type_node. + +2010-09-06 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/36931 + * frontend-passes.c (optimize_binop_array_assignment): New + function. + (optimize_assignment): Call it. + +2010-09-06 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/34145 + * trans-expr.c (gfc_conv_substring): If start and end + of the string reference are equal, set the length to one. + +2010-09-06 Tobias Burnus <burnus@net-b.de> + + PR fortran/45560 + * dump-parse-tree.c (gfc_debug_expr): Use stderr instead of stdout. + +2010-09-06 Tobias Burnus <burnus@net-b.de> + + PR fortran/45560 + * dump-parse-tree.c (gfc_debug_expr): New function. + +2010-09-06 Tobias Burnus <burnus@net-b.de> + + PR fortran/38282 + * intrinsic.c (add_functions): Support IALL, IANY, IPARITY. + (check_specific): Special case for those intrinsics. + * gfortran.h (gfc_isym_id): Add new intrinsics + * intrinsic.h (gfc_check_transf_bit_intrins, + gfc_simplify_iall, gfc_simplify_iany, gfc_simplify_iparity, + gfc_resolve_iall, gfc_resolve_iany, gfc_resolve_iparity): + New prototypes. + * iresolve.c (gfc_resolve_iall, gfc_resolve_iany, + gfc_resolve_iparity, resolve_transformational): New functions. + (gfc_resolve_product, gfc_resolve_sum, + gfc_resolve_parity): Use resolve_transformational. + * check.c (gfc_check_transf_bit_intrins): New function. + * simplify.c (gfc_simplify_iall, gfc_simplify_iany, + gfc_simplify_iparity, do_bit_any, do_bit_ior, + do_bit_xor, simplify_transformation): New functions. + (gfc_simplify_all, gfc_simplify_any, gfc_simplify_parity, + gfc_simplify_sum, gfc_simplify_product): Use simplify_transformation. + * trans-intrinsic.c (gfc_conv_intrinsic_arith, + gfc_conv_intrinsic_function, gfc_is_intrinsic_libcall): + Handle IALL, IANY and IPARITY intrinsics. + * intrinsic.texi (IMAGE_INDEX): Move up to fix alphabetic + order. + (IALL, IANY, IPARITY): Document new intrinsics. + +2010-09-05 Tobias Burnus <burnus@net-b.de> + + PR fortran/45186 + * f95-lang.c (gfc_truthvalue_conversion): Use + fold_build[0-9]_loc instead of fold_build[0-9]. + * convert.c (convert): Ditto. + * trans-intrinsic.c (gfc_conv_intrinsic_conversion, + build_fixbound_expr, build_fix_expr, gfc_conv_intrinsic_aint, + gfc_conv_intrinsic_int, gfc_conv_intrinsic_imagpart, + gfc_conv_intrinsic_conjg, gfc_trans_same_strlen_check, + gfc_conv_intrinsic_bound, gfc_conv_intrinsic_abs, + gfc_conv_intrinsic_cmplx, gfc_conv_intrinsic_mod, + gfc_conv_intrinsic_dim, gfc_conv_intrinsic_sign, + gfc_conv_intrinsic_dprod, gfc_conv_intrinsic_char, + gfc_conv_intrinsic_ctime, gfc_conv_intrinsic_fdate, + gfc_conv_intrinsic_ttynam, gfc_conv_intrinsic_minmax, + gfc_conv_intrinsic_minmax_char, gfc_conv_intrinsic_anyall, + gfc_conv_intrinsic_count, gfc_conv_intrinsic_arith, + gfc_conv_intrinsic_dot_product, gfc_conv_intrinsic_minmaxloc, + gfc_conv_intrinsic_minmaxval, gfc_conv_intrinsic_btest, + gfc_conv_intrinsic_bitop, gfc_conv_intrinsic_not, + gfc_conv_intrinsic_singlebitop, gfc_conv_intrinsic_ibits, + gfc_conv_intrinsic_rlshift, gfc_conv_intrinsic_ishft, + gfc_conv_intrinsic_ishftc, gfc_conv_intrinsic_leadz, + gfc_conv_intrinsic_trailz, gfc_conv_intrinsic_popcnt_poppar, + gfc_conv_intrinsic_ichar, gfc_conv_has_intvalue, + gfc_conv_intrinsic_merge, gfc_conv_intrinsic_spacing, + gfc_conv_intrinsic_rrspacing, gfc_conv_intrinsic_size, + size_of_string_in_bytes, gfc_conv_intrinsic_sizeof, + gfc_conv_intrinsic_storage_size, gfc_conv_intrinsic_strcmp, + gfc_conv_intrinsic_transfer, gfc_conv_allocated, + gfc_conv_associated, gfc_conv_same_type_as, + gfc_conv_intrinsic_trim, gfc_conv_intrinsic_repeat): Ditto. + +2010-09-04 Tobias Burnus <burnus@net-b.de> + + PR fortran/45530 + * resolve.c (resolve_fl_namelist): Change constraint checking + order to prevent endless loop. + +2010-09-04 Janus Weil <janus@gcc.gnu.org> + + PR fortran/45507 + * resolve.c (resolve_allocate_expr): Generate default initializers + already at this point, resolve them and put them into expr3, ... + * trans-stmt.c (gfc_trans_allocate): ... instead of waiting until + translation stage. + +2010-09-03 Tobias Burnus <burnus@net-b.de> + + PR fortran/45186 + * trans-intrinsic.c (gfc_conv_intrinsic_sign, + gfc_conv_intrinsic_leadz): Use build_call_expr_loc instead + of build_call_expr. + * trans-expr.c (gfc_conv_expr_present, gfc_conv_missing_dummy, + gfc_conv_string_length, gfc_conv_substring, + gfc_conv_component_ref, gfc_conv_unary_op, gfc_conv_powi, + gfc_conv_cst_int_power, gfc_conv_string_tmp, gfc_conv_concat_op, + gfc_conv_expr_op, gfc_build_compare_string, + gfc_set_interface_mapping_bounds, gfc_conv_subref_array_arg, + gfc_conv_derived_to_class, conv_isocbinding_procedure, + gfc_conv_procedure_call, fill_with_spaces, + gfc_trans_string_copy, gfc_trans_alloc_subarray_assign, + gfc_trans_structure_assign, gfc_trans_pointer_assignment, + gfc_trans_scalar_assign, gfc_trans_zero_assign, + gfc_trans_array_copy, gfc_trans_array_constructor_copy): Change + fold_build[0-9] to fold_build[0-9]_loc. + * trans-io.c (set_parameter_const, set_parameter_value, + set_parameter_ref, gfc_convert_array_to_string, set_string, + set_internal_unit, io_result, set_error_locus, + nml_get_addr_expr, build_dt): Ditto. + * trans-openmp.c (gfc_omp_clause_default_ctor, + gfc_omp_clause_copy_ctor, gfc_omp_clause_assign_op, + gfc_trans_omp_array_reduction, gfc_trans_omp_atomic, + gfc_trans_omp_do): Ditto. + * trans.c (gfc_add_modify, gfc_build_addr_expr, + gfc_build_array_ref, gfc_trans_runtime_error_vararg, + gfc_trans_runtime_check, gfc_call_malloc, + gfc_allocate_with_status, gfc_allocate_array_with_status, + gfc_call_free, gfc_deallocate_with_status, + gfc_call_realloc): Ditto. + +2010-09-03 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/45159 + * dependency.c (gfc_deb_compare_expr): Compare equal for equal + arglists for pure user functions, or for those intrinsic + functions which are also pure. + * intrinsics.c (add_conv): Mark conversion functions as pure. + (add_char_conversions): Likewise. + +2010-09-03 Daniel Kraft <d@domob.eu> + + PR fortran/34162 + * resolve.c (resolve_actual_arglist): Allow internal procedure + as actual argument with Fortran 2008. + +2010-09-03 Daniel Kraft <d@domob.eu> + + PR fortran/44602 + * gfortran.h (struct gfc_code): Renamed `whichloop' to + `which_construct' as this is no longer restricted to loops. + * parse.h (struct gfc_state_data): New field `construct'. + * match.c (match_exit_cycle): Handle EXIT from non-loops. + * parse.c (push_state): Set `construct' field. + * resolve.c (resolve_select_type): Extend comment. + * trans-stmt.c (gfc_trans_if): Add exit label. + (gfc_trans_block_construct), (gfc_trans_select): Ditto. + (gfc_trans_simple_do): Store exit/cycle labels on the gfc_code itself. + (gfc_trans_do), (gfc_trans_do_while): Ditto. + (gfc_trans_exit): Use new name `which_construct' instead of `whichloop'. + (gfc_trans_cycle): Ditto. + (gfc_trans_if_1): Use fold_build3_loc instead of fold_build3. + +2010-09-03 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * trans-intrinsic.c (gfc_conv_intrinsic_aint): Fix whitespace. + (gfc_conv_intrinsic_ishft): Only evaluate arguments once. + (gfc_conv_intrinsic_ishftc): Only evaluate arguments once. + * intrinsic.texi (RSHIFT): Fix documentation. + +2010-09-02 Tobias Burnus <burnus@net-b.de> + + PR fortran/45186 + * trans-common.c (create_common): Change build[0-9] to + build[0-9]_loc. + * trans-const.c (gfc_conv_constant_to_tree, + gfc_conv_constant_to_tree): Ditto. + * trans-decl.c (gfc_build_qualified_array, build_entry_thunks, + gfc_get_fake_result_decl, gfc_trans_auto_character_variable, + add_argument_checking, create_main_function, + gfc_generate_return): Ditto. + * trans-types.c (gfc_get_dtype, gfc_get_array_type_bounds): Ditto. + * trans-stmt.c (allocate_temp_for_forall_nest_1, + compute_inner_temp_size, compute_overall_iter_number, + generate_loop_for_rhs_to_temp, generate_loop_for_temp_to_lhs, + gfc_conv_elemental_dependencies, gfc_do_allocate, + gfc_evaluate_where_mask, gfc_trans_allocate, + gfc_trans_arithmetic_if, gfc_trans_call, + gfc_trans_character_select, gfc_trans_deallocate, + gfc_trans_do, gfc_trans_do_while, gfc_trans_forall_1, + gfc_trans_forall_loop, gfc_trans_goto, gfc_trans_if_1, + gfc_trans_integer_select, gfc_trans_logical_select, + gfc_trans_pointer_assign_need_temp, gfc_trans_return, + gfc_trans_simple_do, gfc_trans_sync, gfc_trans_where_2, + gfc_trans_where_assign) Ditto. + +2010-09-02 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44541 + * resolve.c (resolve_symbol): Correct check for attributes of CLASS + variable. + +2010-09-02 Tobias Burnus <burnus@net-b.de> + + PR fortran/45489 + * resolve.c (apply_default_init): Mark symbol as referenced, + if it is initialized. + (resolve_symbol): Change intialized check for BT_DERIVED such + that also function results get initialized; remove now obsolete + gfc_set_sym_referenced for BT_CLASS. + +2010-09-01 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44541 + * class.c (gfc_find_derived_vtab): Add component '$def_init'. + * resolve.c (resolve_allocate_expr): Defer handling of default + initialization to 'gfc_trans_allocate'. + (apply_default_init,resolve_symbol): Handle polymorphic dummies. + (resolve_fl_derived): Suppress error messages for vtypes. + * trans-stmt.c (gfc_trans_allocate): Handle initialization via + polymorphic MOLD expression. + * trans-expr.c (gfc_trans_class_init_assign): Now only used for + dummy initialization. + +2010-09-01 Tobias Burnus <burnus@net-b.de> + + * gfortran.texi (preprocessing): Update URL to COCO. + +2010-09-01 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * trans-intrinsic.c (gfc_build_intrinsic_lib_fndecls): Resize + array quad_decls. Remove unnecessary assignment. + +2010-09-01 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * trans-expr.c (gfc_conv_power_op): Handle floating-point types + other than long double. + * mathbuiltins.def: Add builtins from the POW and CPOW family. + * trans.h (gfc_builtin_decl_for_float_kind): New prototype. + * trans-intrinsic.c (gfc_builtin_decl_for_float_kind): Add gfc_ + prefix to function name. + (gfc_build_intrinsic_lib_fndecls): Add cpow prototype. + (gfc_conv_intrinsic_aint): Use gfc_builtin_decl_for_float_kind + function name. + (gfc_conv_intrinsic_exponent): Likewise. + (gfc_conv_intrinsic_abs): Likewise. + (gfc_conv_intrinsic_mod): Likewise. + (gfc_conv_intrinsic_sign): Likewise. + (gfc_conv_intrinsic_arith): Likewise. + (gfc_conv_intrinsic_fraction): Likewise. + (gfc_conv_intrinsic_nearest): Likewise. + (gfc_conv_intrinsic_spacing): Likewise. + (gfc_conv_intrinsic_rrspacing): Likewise. + (gfc_conv_intrinsic_scale): Likewise. + (gfc_conv_intrinsic_set_exponent): Likewise. + +2010-09-01 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * intrinsic.c: Add EXECUTE_COMMAND_LINE intrinsic. + * intrinsic.h (gfc_resolve_execute_command_line): New function. + * iresolve.c (gfc_resolve_execute_command_line): New function. + * gfortran.h (GFC_ISYM_EXECUTE_COMMAND_LINE): New value. + * intrinsic.texi: Document EXECUTE_COMMAND_LINE. + +2010-08-31 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/38282 + * f95-lang.c (gfc_init_builtin_functions): Define popcount{,l,ll} + and parity{,l,ll} builtins. + * trans-intrinsic.c (gfc_conv_intrinsic_popcnt_poppar): New function. + (gfc_conv_intrinsic_function): Call above new functions. + * simplify.c (gfc_simplify_popcnt, gfc_simplify_poppar): New + functions. + * intrinsic.texi: Document POPCNT and POPPAR. + +2010-08-30 Janus Weil <janus@gcc.gnu.org> + + PR fortran/45456 + * resolve.c (resolve_structure_cons): Handle pointer-valued PPCs. + +2010-08-30 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * Make-lang.in: Add frontend-passes.o dependencies. + +2010-08-29 Janus Weil <janus@gcc.gnu.org> + + PR fortran/42769 + * resolve.c (resolve_structure_cons): For derived types, make sure the + type has been resolved. + (resolve_typebound_procedures): Make sure the vtab has been generated. + +2010-08-29 Janus Weil <janus@gcc.gnu.org> + + PR fortran/45439 + * match.c (gfc_match_select_type): Give the associate-name the + FL_VARIABLE attribute. + +2010-08-28 Steven G. Kargl <kargl@gcc.gnu.org> + + * simplify.c (gfc_simplify_bessel_n2): Fix indention + and argument type. + +2010-08-28 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/45436 + * trans-types.c (gfc_init_kinds): Disable TFmode. + +2010-08-27 Janus Weil <janus@gcc.gnu.org> + + PR fortran/45432 + * match.c (gfc_match_allocate): Avoid double free on error. + +2010-08-27 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/32049 + * gfortran.h (gfc_real_info): Add c_float128 field. + * mathbuiltins.def: Indicate which builtins are const. + * trans-types.h (float128_type_node, complex_float128_type_node, + gfc_real16_is_float128): New variables. + * trans-types.c (float128_type_node, complex_float128_type_node, + gfc_real16_is_float128): New variables. + (gfc_init_kinds): Allow TFmode. + (gfc_build_real_type): Mark __float128 types as such. + (gfc_init_types): Initialize float128_type_node and + complex_float128_type_node + * f95-lang.c (gfc_init_builtin_functions): Adjust for new + argument of OTHER_BUILTIN macro. + * trans-intrinsic.c (gfc_intrinsic_map_t): Likewise. + (builtin_decl_for_precision): Special case for __float128. + (builtin_decl_for_float_kind): Likewise. + (define_quad_builtin): New function. + (gfc_build_intrinsic_lib_fndecls): Create all __float128 + library decls if necessary. Store them in the real16_decl and + complex16_decl builtin map fields. + (gfc_get_intrinsic_lib_fndecl): Handle q-suffixed __float128 + library function names. + +2010-08-27 Tobias Burnus <burnus@net-b.de> + + PR fortran/33197 + * gcc/fortran/intrinsic.c (add_functions): Add norm2 and parity. + * gcc/fortran/intrinsic.h (gfc_check_norm2, gfc_check_parity): + gfc_simplify_norm2, gfc_simplify_parity, gfc_resolve_norm2, + gfc_resolve_parity): New prototypes. + * gcc/fortran/gfortran.h (gfc_isym_id): New enum items + GFC_ISYM_NORM2 and GFC_ISYM_PARITY. + * gcc/fortran/iresolve.c (gfc_resolve_norm2, + gfc_resolve_parity): New functions. + * gcc/fortran/check.c (gfc_check_norm2, gfc_check_parity): + New functions. + * gcc/fortran/trans-intrinsic.c (gfc_conv_intrinsic_arith, + gfc_conv_intrinsic_function): Handle NORM2 and PARITY. + * gcc/fortran/intrinsic.texi (NORM2, PARITY): Add. + * gcc/fortran/simplify.c (simplify_transformation_to_array): + Add post-processing opterator. + (gfc_simplify_all, gfc_simplify_any, gfc_simplify_count, + gfc_simplify_product, gfc_simplify_sum): Update call. + (add_squared, do_sqrt, gfc_simplify_norm2, do_xor, + gfc_simplify_parity): New functions. + +2010-08-27 Janus Weil <janus@gcc.gnu.org> + + PR fortran/45420 + * match.c (select_type_set_tmp): Add the possibility to reset the + temporary to NULL. + (gfc_match_class_is): Reset the temporary in CLASS DEFAULT clauses. + +2010-08-27 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/45159 + * dependency.c (check_section_vs_section): Single test for + identical strides which takes into account that only one + of the strides may be NULL. + +2010-08-27 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/43217 + * primary.c (match_hollerith_constant): Calculate padding needed to + fill default integer and allocate string for that size. Set pad bytes + to ' '. + * gfortran.h: Add hollerith pad value to type spec union. + * data.c (create_character_initializer): Fix spelling of function name. + Use hollerith pad value to calculate length. + * arith.c (hollerith2representation); Use hollerith pad value to + calculate length. + +2010-08-26 Daniel Kraft <d@domob.eu> + + PR fortran/38936 + PR fortran/44047 + PR fortran/45384 + * gfortran.h (struct gfc_association_list): New flag `dangling'. + (gfc_build_block_ns): Declared here... + * parse.h (gfc_build_block_ns): ...instead of here. + * trans.h (gfc_process_block_locals): Expect additionally the + gfc_association_list of BLOCK (if present). + * match.c (select_type_set_tmp): Create sym->assoc for temporary. + * resolve.c (resolve_variable): Only check for invalid *array* + references on associate-names. + (resolve_assoc_var): New method with code previously in resolve_symbol. + (resolve_select_type): Use association to give the selector and + temporaries their values instead of ordinary assignment. + (resolve_fl_var_and_proc): Allow CLASS associate-names. + (resolve_symbol): Use new `resolve_assoc_var' instead of inlining here. + * trans-stmt.c (gfc_trans_block_construct): Pass association-list + to `gfc_process_block_locals' to match new interface. + * trans-decl.c (gfc_get_symbol_decl): Don't defer associate-names + here automatically. + (gfc_process_block_locals): Defer them rather here when linked to + from the BLOCK's association list. + +2010-08-25 Jakub Jelinek <jakub@redhat.com> + + * trans-decl.c (gfc_build_intrinsic_function_decls): Set + TREE_NOTHROW on fndecls that can't throw. Set + TREE_READONLY on gfor_fndecl_math_ishftc{4,8,16}. + (gfc_build_builtin_function_decls): Set TREE_NOTHROW on + gfor_fndecl_associated. + +2010-08-23 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/45380 + * frontend-passes.c (optimize_equality): Don't optimize array equality + +2010-08-23 Janus Weil <janus@gcc.gnu.org> + + PR fortran/45366 + * resolve.c (resolve_procedure_interface): New function split off from + 'resolve_symbol'. + (resolve_formal_arglist): Call it here ... + (resolve_symbol): ... and here. + +2010-08-22 Joseph Myers <joseph@codesourcery.com> + + * Make-lang.in (gfortranspec.o): Update dependencies. + * gfortranspec.c: Include coretypes.h before gcc.h. Include + opts.h. + (MATH_LIBRARY, FORTRAN_LIBRARY): Remove initial "-l". + (ADD_ARG_LIBGFORTRAN, Option, lookup_option): Remove. + (g77_xargc): Make unsigned. + (g77_xargv): Change to g77_x_decoded_options. + (g77_newargc): Make unsigned. + (g77_newargv): Change to g77_new_decoded_options. + (strings_same, options_same): New. + (append_arg): Use cl_decoded_option structures. + (append_option): New. + (add_arg_libgfortran): New. + (lang_specific_driver): Use cl_decoded_option structures. + +2010-08-21 Janus Weil <janus@gcc.gnu.org> + + PR fortran/45271 + PR fortran/45290 + * class.c (add_proc_comp): Add static initializer for PPCs. + (add_procs_to_declared_vtab): Modified comment. + * module.c (mio_component): Add argument 'vtype'. Don't read/write the + initializer if the component is part of a vtype. + (mio_component_list): Add argument 'vtype', pass it on to + 'mio_component'. + (mio_symbol): Modified call to 'mio_component_list'. + * trans.h (gfc_conv_initializer): Modified prototype. + (gfc_trans_assign_vtab_procs): Removed. + * trans-common.c (create_common): Modified call to + 'gfc_conv_initializer'. + * trans-decl.c (gfc_get_symbol_decl,get_proc_pointer_decl, + gfc_emit_parameter_debug_info): Modified call to + 'gfc_conv_initializer'. + (build_function_decl): Remove assertion. + * trans-expr.c (gfc_conv_derived_to_class,gfc_trans_class_assign): + Removed call to 'gfc_trans_assign_vtab_procs'. + (gfc_conv_initializer): Add argument 'procptr'. + (gfc_conv_structure): Modified call to 'gfc_conv_initializer'. + (gfc_trans_assign_vtab_procs): Removed. + * trans-stmt.c (gfc_trans_allocate): Removed call to + 'gfc_trans_assign_vtab_procs'. + +2010-08-21 Tobias Burnus <burnus@net-b.de> + + PR fortran/36158 + PR fortran/33197 + * intrinsic.c (add_sym): Init value attribute. + (set_attr_value): New function. + (add_functions) Use it and add JN/YN resolvers. + * symbol.c (gfc_copy_formal_args_intr): Copy value attr. + * intrinsic.h (gfc_resolve_bessel_n2): New prototype. + * gfortran.h (gfc_intrinsic_arg): Add value attribute. + * iresolve.c (gfc_resolve_bessel_n2): New function. + * trans-intrinsic.c (gfc_get_symbol_for_expr): Create + formal arg list. + (gfc_conv_intrinsic_function,gfc_is_intrinsic_libcall): + Add GFC_ISYM_JN2/GFC_ISYM_YN2 as case value. + * simplify.c (): For YN set to -INF if previous values + was -INF. + * trans-expr.c (gfc_conv_procedure_call): Don't crash + if sym->as is NULL. + * iresolve.c (gfc_resolve_extends_type_of): Set the + type of the dummy argument to the one of the actual. + +2010-08-20 Joseph Myers <joseph@codesourcery.com> + + * lang.opt (MD, MMD): Use NoDriverArg instead of NoArgDriver. + +2010-08-20 Joseph Myers <joseph@codesourcery.com> + + * gfortranspec.c (lang_specific_driver): Refer to -lgfortran in + comment, not -lg2c. + +2010-08-20 Nathan Froyd <froydnj@codesourcery.com> + + * trans-openmp.c: Use FOR_EACH_VEC_ELT. + +2010-08-19 Daniel Kraft <d@domob.eu> + + PR fortran/29785 + PR fortran/45016 + * trans.h (struct gfc_se): New flag `byref_noassign'. + * trans-array.h (gfc_conv_shift_descriptor_lbound): New method. + (gfc_conv_array_extent_dim), (gfc_conv_descriptor_size): New methods. + * expr.c (gfc_check_pointer_assign): Allow bounds and rank remapping + and check for compile-time errors with those. + * trans-decl.c (trans_associate_var): Use new routine + `gfc_conv_shift_descriptor_lbound' instead of doing it manually. + * trans-array.c (gfc_conv_shift_descriptor_lbound): New method. + (gfc_conv_array_extent_dim), (gfc_conv_descriptor_size): New methods. + (gfc_array_init_size): Use new `gfc_conv_array_extent_dim'. + (gfc_conv_expr_descriptor): Handle new flag `byref_noassign'. + * trans-expr.c (gfc_trans_pointer_assignment): Handle bounds and + rank remapping for assignment. + +2010-08-19 Tobias Burnus <burnus@net-b.de> + + * intrinsic.texi (Bessel_jn, Bessel_yn): Fix typo. + * * simplify.c (gfc_simplify_bessel_yn): Change recursive + into recurrence. + +2010-08-19 Tobias Burnus <burnus@net-b.de> + + PR fortran/36158 + PR fortran/33197 + * check.c (gfc_check_bessel_n2): New function. + * gfortran.h (gfc_isym_id): Add GFC_ISYM_JN2 and GFC_ISYM_YN2. + * intrinsic.c (add_functions): Add transformational version + of the Bessel_jn/yn intrinsics. + * intrinsic.h (gfc_check_bessel_n2,gfc_simplify_bessel_jn2, + gfc_simplify_bessel_yn2): New prototypes. + * intrinsic.texi (Bessel_jn, Bessel_yn): Document + transformational variant. + * simplify.c (gfc_simplify_bessel_jn, gfc_simplify_bessel_yn): + Check for negative order. + (gfc_simplify_bessel_n2,gfc_simplify_bessel_jn2, + gfc_simplify_bessel_yn2): New functions. + +2010-08-19 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/41859 + * resolve.c (resolve_transfer): Traverse operands and set expression + to be checked to a non EXPR_OP type. + +2010-08-19 Janus Weil <janus@gcc.gnu.org> + + PR fortran/45290 + * gfortran.h (gfc_add_save): Modified prototype. + * decl.c (add_init_expr_to_sym): Defer checking of proc pointer init. + (match_pointer_init): New function to match F08 pointer initialization. + (variable_decl,match_procedure_decl,match_ppc_decl): Use + 'match_pointer_init'. + (match_attr_spec): Module variables are implicitly SAVE. + (gfc_match_save): Modified call to 'gfc_add_save'. + * expr.c (gfc_check_assign_symbol): Extra checks for pointer + initialization. + * primary.c (gfc_variable_attr): Handle SAVE attribute. + * resolve.c (resolve_structure_cons): Add new argument and do pointer + initialization checks. + (gfc_resolve_expr): Modified call to 'resolve_structure_cons'. + (resolve_values): Call 'resolve_structure_cons' directly with init arg. + (resolve_fl_variable): Handle SAVE_IMPLICIT. + * symbol.c (gfc_add_save,gfc_copy_attr,save_symbol): Handle + SAVE_IMPLICIT. + * trans-decl.c (gfc_create_module_variable): Module variables with + TARGET can already exist. + * trans-expr.c (gfc_conv_variable): Check for 'current_function_decl'. + (gfc_conv_initializer): Implement non-NULL pointer + initialization. + +2010-08-18 Tobias Burnus <burnus@net-b.de> + + PR fortran/45295 + * intrinsic.texi (selected_char_kind): Document ISO_10646 + support. + +2010-08-17 Jakub Jelinek <jakub@redhat.com> + + PR fortran/45304 + * trans-decl.c (build_library_function_decl_1): Chain on + void_list_node instead of creating a new TREE_LIST. + * trans-intrinsic.c (gfc_get_intrinsic_lib_fndecl): Likewise. + * trans-types.c (gfc_get_function_type): Likewise. Set + typelist to void_list_node for the main program. + +2010-08-17 Daniel Kraft <d@domob.eu> + + PR fortran/38936 + * gfortran.h (struct gfc_association_list): New member `where'. + (gfc_is_associate_pointer) New method. + * match.c (gfc_match_associate): Remember locus for each associate + name matched and do not try to set variable flag. + * parse.c (parse_associate): Use remembered locus for symbols. + * primary.c (match_variable): Instead of variable-flag check for + associate names set it for all such names used. + * symbol.c (gfc_is_associate_pointer): New method. + * resolve.c (resolve_block_construct): Don't generate assignments + to give associate-names their values. + (resolve_fl_var_and_proc): Allow associate-names to be deferred-shape. + (resolve_symbol): Set some more attributes for associate variables, + set variable flag here and check it and don't try to build an + explicitely shaped array-spec for array associate variables. + * trans-expr.c (gfc_conv_variable): Dereference in case of association + to scalar variable. + * trans-types.c (gfc_is_nodesc_array): Handle array association symbols. + (gfc_sym_type): Return pointer type for association to scalar vars. + * trans-decl.c (gfc_get_symbol_decl): Defer association symbols. + (trans_associate_var): New method. + (gfc_trans_deferred_vars): Handle association symbols. + +2010-08-16 Joseph Myers <joseph@codesourcery.com> + + * lang.opt (MDX): Change back to MD. Mark NoDriverArg instead of + RejectDriver. + (MMDX): Change back to MMD. Mark NoDriverArg instead of + RejectDriver. + * cpp.c (gfc_cpp_handle_option): Use OPT_MD and OPT_MMD instead of + OPT_MDX and OPT_MMDX. + +2010-08-16 Joseph Myers <joseph@codesourcery.com> + + * lang.opt (MDX, MMDX): Mark RejectDriver. + +2010-08-15 Janus Weil <janus@gcc.gnu.org> + + * trans-expr.c (gfc_trans_assign_vtab_procs): Clean up (we don't have + vtabs for generics any more). + +2010-08-15 Daniel Kraft <d@domob.eu> + + PR fortran/38936 + * gfortran.h (gfc_find_proc_namespace): New method. + * expr.c (gfc_build_intrinsic_call): No need to build symtree messing + around with namespace. + * symbol.c (gfc_find_proc_namespace): New method. + * trans-decl.c (gfc_build_qualified_array): Use it for correct + value of nest. + * primary.c (gfc_match_varspec): Handle associate-names as arrays. + * parse.c (parse_associate): Removed assignment-generation here... + * resolve.c (resolve_block_construct): ...and added it here. + (resolve_variable): Handle names that are arrays but were not parsed + as such because of association. + (resolve_code): Fix BLOCK resolution. + (resolve_symbol): Generate array-spec for associate-names. + +2010-08-15 Tobias Burnus <burnus@net-b.de> + + PR fortran/45211 + * decl.c (verify_c_interop_param): Remove superfluous space (" "). + (verify_c_interop): Handle unresolved DT with bind(C). + +2010-08-15 Tobias Burnus <burnus@net-b.de> + + * trans-expr.c (gfc_conv_expr_present): Regard nullified + pointer arrays as absent. + (gfc_conv_procedure_call): Handle EXPR_NULL for non-pointer + dummys as absent argument. + * interface.c (compare_actual_formal,compare_parameter): + Ditto. + +2010-08-15 Tobias Burnus <burnus@net-b.de> + + * interface.c (compare_pointer, ): Allow passing TARGETs to pointers + dummies with intent(in). + +2010-08-15 Daniel Kraft <d@domob.eu> + + PR fortran/45197 + * decl.c (gfc_match_prefix): Match IMPURE prefix and mark ELEMENTAL + routines not IMPURE also as PURE. + * intrinsic.c (enum klass): New class `CLASS_PURE' and renamed + `NO_CLASS' in `CLASS_IMPURE'. + (add_sym): Set symbol-attributes `pure' and `elemental' correctly. + (add_sym_0s): Renamed `NO_CLASS' in `CLASS_IMPURE'. + (add_functions): Ditto. + (add_subroutines): Ditto and mark `MOVE_ALLOC' as CLASS_PURE. + * resolve.c (gfc_pure): Do not treat ELEMENTAL as automatically PURE. + (resolve_formal_arglist): Check that arguments to ELEMENTAL procedures + are not ALLOCATABLE and have their INTENT specified. + +2010-08-13 Daniel Kraft <d@domob.eu> + + * gfortran.h (array_type): New type `AS_IMPLIED_SHAPE'. + * array.c (gfc_match_array_spec): Match implied-shape specification and + handle AS_IMPLIED_SHAPE correctly otherwise. + * decl.c (add_init_expr_to_sym): Set upper bounds for implied-shape. + (variable_decl): Some checks for implied-shape declaration. + * resolve.c (resolve_symbol): Assert that array-spec is no longer + AS_IMPLIED_SHAPE in any case. + +2010-08-12 Joseph Myers <joseph@codesourcery.com> + + * lang.opt (MD, MMD): Change to MDX and MMDX. + * cpp.c (gfc_cpp_handle_option): Use OPT_MMD and OPT_MMDX. + +2010-08-11 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44595 + * intrinsic.c (gfc_current_intrinsic_arg): Change type from 'char' to + 'gfc_intrinsic_arg'. + (check_arglist,check_specific): Add reference to 'name' field. + (init_arglist): Remove reference to 'name' field. + * intrinsic.h (gfc_current_intrinsic_arg): Modify prototype. + * check.c (variable_check): Reverse order of checks. Respect intent of + formal arg. + (int_or_proc_check): New function. + (coarray_check): New function. + (allocatable_check): New function. + (gfc_check_allocated,gfc_check_move_alloc): Use 'allocatable_check'. + (gfc_check_complex): Use 'int_or_real_check'. + (gfc_check_lcobound,gfc_check_image_index,gfc_check_this_image, + gfc_check_ucobound): Use 'coarray_check'. + (gfc_check_pack): Use 'real_or_complex_check'. + (gfc_check_alarm_sub,gfc_check_signal,gfc_check_signal_sub): Use + 'int_or_proc_check'. + (scalar_check,type_check,numeric_check,int_or_real_check, + real_or_complex_check,kind_check,double_check,logical_array_check, + array_check,same_type_check,rank_check,nonoptional_check, + kind_value_check,gfc_check_a_p,gfc_check_associated,gfc_check_cmplx, + gfc_check_cshift,gfc_check_dcmplx,gfc_check_dot_product,gfc_check_dprod, + gfc_check_eoshift,gfc_check_fn_rc2008,gfc_check_index,gfc_check_kind, + gfc_check_matmul,gfc_check_minloc_maxloc,check_reduction,gfc_check_null, + gfc_check_present,gfc_check_reshape,gfc_check_same_type_as, + gfc_check_spread,gfc_check_unpack,gfc_check_random_seed, + gfc_check_getarg,gfc_check_and,gfc_check_storage_size): Add reference + to 'name' field. + +2010-08-10 Daniel Kraft <d@domob.eu> + + * gfortran.texi (Interoperability with C): Fix ordering in menu + and add new subsection about pointers. + (Interoperable Subroutines and Functions): Split off the pointer part. + (working with Pointers): New subsection with extended discussion + of pointers (especially procedure pointers). + +2010-08-09 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/44235 + * array.c (gfc_ref_dimen_size): Add end argument. + If end is non-NULL, calculate it. + (ref_size): Adjust call to gfc_ref_dimen_size. + (gfc_array_dimen_size): Likewise. + (gfc_array_res_shape): Likewise. + * gfortran.h: Adjust prototype for gfc_ref_dimen_size. + * resolve.c (resolve_array_ref): For stride not equal to -1, + fill in the lowest possible end. + +2010-08-09 Janus Weil <janus@gcc.gnu.org> + + * intrinsic.texi: Correct documentation of ASINH, ACOSH and ATANH. + +2010-08-07 Nathan Froyd <froydnj@codesourcery.com> + + * interface.c (compare_actual_formal): Use XALLOCAVEC instead of + alloca. + (check_some_aliasing): Likewise. + * trans-intrinsic.c (gfc_conv_intrinsic_conversion): Likewise. + (gfc_conv_intrinsic_int): Likewise. + (gfc_conv_intrinsic_lib_function): Likewise. + (gfc_conv_intrinsic_cmplx): Likewise. + (gfc_conv_intrinsic_ctime): Likewise. + (gfc_conv_intrinsic_fdate): Likewise. + (gfc_conv_intrinsic_ttynam): Likewise. + (gfc_conv_intrinsic_minmax): Likewise. + (gfc_conv_intrinsic_minmax_char): Likewise. + (gfc_conv_intrinsic_ishftc): Likewise. + (gfc_conv_intrinsic_index_scan_verify): Likewise. + (gfc_conv_intrinsic_merge): Likewise. + (gfc_conv_intrinsic_trim): Likewise. + * trans.c (gfc_trans_runtime_error_vararg): Likewise. + +2010-08-06 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/45159 + * dependency.c (check_section_vs_section): Handle cases where + the start expression coincides with the lower or upper + bound of the array. + +2010-08-04 Janus Weil <janus@gcc.gnu.org> + + PR fortran/42207 + PR fortran/44064 + PR fortran/44065 + * class.c (gfc_find_derived_vtab): Do not generate vtabs for class + container types. Do not artificially increase refs. Commit symbols one + by one. + * interface.c (compare_parameter): Make sure vtabs are present before + generating module variables. + * resolve.c (resolve_allocate_expr): Ditto. + +2010-08-04 Tobias Burnus <burnus@net-b.de> + + PR fortran/45183 + PR fortran/44857 + * resolve.c (resolve_structure_cons): Fix + freeing of charlen. + +2010-08-04 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/42051 + PR fortran/44064 + * symbol.c (changed_syms): Made static again. + (gfc_symbol_state): Don't conditionalize on GFC_DEBUG. + Changed conditional internal error into assert. + Rename function to ... + (gfc_enforce_clean_symbol_state): ... this. + * gfortran.h (gfc_symbol_state, gfc_enforce_clean_symbol_state): + Rename the former to the latter. + * parse.c (decode_statement, decode_omp_directive, + decode_gcc_attribute): Update callers accordingly. Don't conditionalize + on GFC_DEBUG. + (changed_syms): Remove declaration. + (next_statement): Use gfc_enforce_clean_symbol_state. + +2010-08-04 Tobias Burnus <burnus@net-b.de> + + PR fortran/44857 + * resolve.c (resolve_structure_cons): Fix handling of + initialization structure constructors with character + elements of the wrong length. + * array.c (gfc_check_iter_variable): Add NULL check. + (gfc_resolve_character_array_constructor): Also truncate + character length. + +2010-08-04 Tobias Burnus <burnus@net-b.de> + + * trans-io.c (gfc_build_io_library_fndecls): Fix return + value of some libgfortran functions. + +2010-08-03 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/45159 + * dependency.c (gfc_deb_compare_expr): Remove any integer + conversion functions to larger types from both arguments. + Remove handling these functions futher down. + +2010-08-03 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44584 + PR fortran/45161 + * class.c (add_procs_to_declared_vtab1): Don't add erroneous procedures. + * resolve.c (resolve_tb_generic_targets): Check for errors. + +2010-08-02 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/45159 + * depencency.c (gfc_dep_resolver): Fix logic for when a loop + can be reversed. + +2010-08-02 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/36854 + * dependency.h: Add prototype for gfc_are_identical_variables. + * frontend-passes.c: Include depencency.h. + (optimimize_equality): Use gfc_are_identical_variables. + * dependency.c (identical_array_ref): New function. + (gfc_are_identical_variables): New function. + (gfc_deb_compare_expr): Use gfc_are_identical_variables. + * dependency.c (gfc_check_section_vs_section). Rename gfc_ + prefix from statc function. + (check_section_vs_section): Change arguments to gfc_array_ref, + adjust function body accordingly. + +2010-08-02 Mikael Morin <mikael@gcc.gnu.org> + Janus Weil <janus@gcc.gnu.org> + + PR fortran/42051 + PR fortran/44064 + PR fortran/45151 + * intrinsic.c (gfc_get_intrinsic_sub_symbol): Commit changed symbol. + * symbol.c (gen_cptr_param, gen_fptr_param, gen_shape_param, + gfc_copy_formal_args, gfc_copy_formal_args_intr, + gfc_copy_formal_args_ppc, generate_isocbinding_symbol): Ditto. + * parse.c (parse_derived_contains, parse_spec, parse_progunit): + Call reject_statement in case of error. + (match_deferred_characteritics): Call gfc_undo_symbols in case match + fails. + +2010-08-01 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44912 + * class.c (gfc_build_class_symbol): Make '$vptr' component private. + (gfc_find_derived_vtab): Make vtabs and vtypes public. + * module.c (read_module): When reading module files, always import + vtab and vtype symbols. + +2010-07-31 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/42051 + PR fortran/44064 + * symbol.c (changed_syms): Made non-static. + * parse.c (changed_syms): Declare new external. + (next_statement): Assert changed_syms is NULL at the beginning. + +2010-07-30 Janus Weil <janus@gcc.gnu.org> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/44929 + * match.c (match_type_spec): Try to parse derived types before + intrinsic types. + +2010-07-30 Mikael Morin <mikael@gcc.gnu.org> + + * gfortran.h (gfc_release_symbol): New prototype. + * symbol.c (gfc_release_symbol): New. Code taken from free_sym_tree. + (gfc_undo_symbols, free_sym_tree, gfc_free_finalizer): + Use gfc_release_symbol. + * parse.c (gfc_fixup_sibling_symbols): Ditto. + * resolve.c (resolve_symbol): Ditto. + +2010-07-29 Tobias Burnus <burnus@net-b.de> + + PR fortran/45087 + PR fortran/45125 + * trans-decl.c (gfc_get_extern_function_decl): Correctly handle + external procedure declarations in modules. + (gfc_get_symbol_decl): Modify assert. + +2010-07-29 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44962 + * resolve.c (resolve_fl_derived): Call gfc_resolve_array_spec. + +2010-07-29 Janus Weil <janus@gcc.gnu.org> + + PR fortran/45004 + * trans-stmt.h (gfc_trans_class_init_assign): New prototype. + (gfc_trans_class_assign): Modified prototype. + * trans.h (gfc_conv_intrinsic_move_alloc): New prototype. + * trans-expr.c (gfc_trans_class_init_assign): Split off from ... + (gfc_trans_class_assign): ... here. Modified actual arguments. + * trans-intrinsic.c (gfc_conv_intrinsic_move_alloc): New function to + handle the MOVE_ALLOC intrinsic with scalar and class arguments. + * trans.c (trans_code): Call 'gfc_conv_intrinsic_move_alloc'. + +2010-07-29 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/42051 + PR fortran/44064 + * class.c (gfc_find_derived_vtab): Accept or discard newly created + symbols before returning. + +2010-07-29 Joseph Myers <joseph@codesourcery.com> + + * lang.opt (cpp): Remove Joined and Separate markers. + (cpp=): New internal option. + * lang-specs.h (F951_CPP_OPTIONS): Generate -cpp= option. + * cpp.c (gfc_cpp_handle_option): Handle OPT_cpp_ instead of + OPT_cpp. + +2010-07-29 Daniel Kraft <d@domob.eu> + + PR fortran/45117 + * array.c (resolve_array_bound): Fix error message to properly handle + non-variable expressions. + +2010-07-28 Mikael Morin <mikael@gcc.gnu.org> + + * decl.c (free_value): Also free repeat field. + * data.c (gfc_assign_data_value): Always free offset before returning. + +2010-07-28 Daniel Kraft <d@domob.eu> + + * gfortran.h (gfc_build_intrinsic_call): New method. + * expr.c (gfc_build_intrinsic_call): New method. + * simplify.c (range_check): Ignore non-constant value. + (simplify_bound_dim): Handle non-variable expressions and + fix memory leak with non-free'ed expression. + (simplify_bound): Handle non-variable expressions. + (gfc_simplify_shape): Ditto. + (gfc_simplify_size): Ditto, but only in certain cases possible. + +2010-07-28 Joseph Myers <joseph@codesourcery.com> + + * gfortranspec.c (SWITCH_TAKES_ARG, WORD_SWITCH_TAKES_ARG): + Remove. + +2010-07-28 Tobias Burnus <burnus@net-b.de> + + PR fortran/45077 + * trans-types.c (gfc_get_derived_type): Fix DT declaration + from modules for whole-file mode. + +2010-07-27 Joseph Myers <joseph@codesourcery.com> + + * gfortran.h (gfc_handle_option): Update prototype and return + value type. + * options.c (gfc_handle_option): Update prototype and return value + type. + +2010-07-27 Joseph Myers <joseph@codesourcery.com> + + * cpp.c (gfc_cpp_init_options): Update prototype. Use number of + decoded options in allocating deferred_opt. + * cpp.h (gfc_cpp_init_options): Update prototype. + * f95-lang.c (LANG_HOOKS_OPTION_LANG_MASK): Define. + * gfortran.h (gfc_option_lang_mask): New. + (gfc_init_options): Update prototype. + * options.c (gfc_option_lang_mask): New. + (gfc_init_options): Update prototype. Pass new arguments to + gfc_cpp_init_options. + +2010-07-26 Tobias Burnus <burnus@net-b.de> + + PR fortran/40873 + * trans-decl.c (gfc_get_extern_function_decl): Fix generation + for functions which are later in the same file. + (gfc_create_function_decl, build_function_decl, + build_entry_thunks): Add global argument. + * trans.c (gfc_generate_module_code): Update + gfc_create_function_decl call. + * trans.h (gfc_create_function_decl): Update prototype. + * resolve.c (resolve_global_procedure): Also resolve for + IFSRC_IFBODY. + +2010-07-26 Richard Henderson <rth@redhat.com> + + PR target/44132 + * f95-lang.c (LANG_HOOKS_WRITE_GLOBALS): New. + (gfc_write_global_declarations): New. + +2010-07-26 Tobias Burnus <burnus@net-b.de> + + PR fortran/45066 + * trans-io.c (build_dt): Use NULL_TREE rather than NULL + for call to transfer_namelist_element. + * trans-decl.c (gfc_get_symbol_decl): Also set sym->backend_decl + for -fwhole-file. + +2010-07-25 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/40628 + * Make-lang.in: Add fortran/frontend-passes.o. + * gfortran.h: Add prototype for gfc_run_passes. + * resolve.c (gfc_resolve): Call gfc_run_passes. + * frontend-passes.c: New file. + +2010-07-25 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/42852 + * scanner.c (gfc_next_char_literal): Enable truncation warning for + free-form '&'. + +2010-07-25 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/44660 + * gfortran.h (gfc_namespace): New field old_equiv. + (gfc_free_equiv_until): New prototype. + * match.c (gfc_free_equiv_until): New, renamed from gfc_free_equiv with + a parameterized stop condition. + (gfc_free_equiv): Use gfc_free_equiv_until. + * parse.c (next_statement): Save equivalence list. + (reject_statement): Restore equivalence list. + +2010-07-25 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/42852 + * scanner.c (gfc_next_char_literal): Move check for truncation earlier + in the function so that it does not get missed by early exits. + (load_line): Add checks for quoted strings and free form comments to + disable warnings on comments. Add check for ampersand as first + character after truncation and don't warn for this case, but warn if + there are subsequent non-whitespace characters. + +2010-07-24 Tobias Burnus <burnus@net-b.de> + + PR fortran/40011 + * parse.c (gfc_parse_file): Do not override + gfc_global_ns_list items. + +2010-07-24 Tobias Burnus <burnus@net-b.de> + + * options.c (gfc_init_options): Enable -fwhole-file by default. + * interface.c (compare_parameter): Assume a Hollerith constant is + compatible with all other argument types. + +2010-07-23 Tobias Burnus <burnus@net-b.de> + + PR fortran/44945 + * trans-decl.c (gfc_get_symbol_decl): Use module decl with + -fwhole-file also for derived types. + * trans-types.c (copy_dt_decls_ifequal): Remove static and + rename to gfc_copy_dt_decls_ifequal. + (gfc_get_derived_type): Update call. + * trans-types.h (gfc_copy_dt_decls_ifequal): Add prototype. + +2010-07-23 Tobias Burnus <burnus@net-b.de> + + PR fortran/45030 + * resolve.c (resolve_global_procedure): Properly handle ENTRY. + +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 + * resolve.c (is_external_proc): Prevent procedure pointers from being + regarded as external procedures. + +2010-06-29 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44696 + * trans-intrinsic.c (gfc_conv_associated): Handle polymorphic variables + passed as second argument of ASSOCIATED. + +2010-06-29 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/44582 + * trans-expr.c (arrayfunc_assign_needs_temporary): New function + to determine if a function assignment can be made without a + temporary. + (gfc_trans_arrayfunc_assign): Move all the conditions that + suppress the direct function call to the above new functon and + call it. + +2010-06-28 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/40158 + * interface.c (argument_rank_mismatch): New function. + (compare_parameter): Call new function instead of generating + the error directly. + +2010-06-28 Nathan Froyd <froydnj@codesourcery.com> + + * trans-openmp.c (dovar_init): Define. Define VECs containing it. + (gfc_trans_omp_do): Use a VEC to accumulate variables and their + initializers. + +2010-06-28 Steven Bosscher <steven@gcc.gnu.org> + + * Make-lang.in: Update dependencies. + +2010-06-27 Nathan Froyd <froydnj@codesourcery.com> + + * gfortran.h (gfc_code): Split backend_decl field into cycle_label + and exit_label fields. + * trans-openmp.c (gfc_trans_omp_do): Assign to new fields + individually. + * trans-stmt.c (gfc_trans_simple_do): Likewise. + (gfc_trans_do): Likewise. + (gfc_trans_do_while): Likewise. + (gfc_trans_cycle): Use cycle_label directly. + (gfc_trans_exit): Use exit_label directly. + +2010-06-27 Daniel Kraft <d@domob.eu> + + * dump-parse-tree.c (show_symbol): Dump target-expression for + associate names. + (show_code_node): Make distinction between BLOCK and ASSOCIATE. + (show_namespace): Use show_level for correct indentation of + "inner namespaces" (contained procedures or BLOCK). + +2010-06-27 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/44678 + * dump-parse-tree.c (show_code_node): Show namespace for + EXEC_BLOCK. + +2010-06-26 Tobias Burnus <burnus@net-b.de> + + * decl.c (gfc_match_decl_type_spec): Support + TYPE(intrinsic-type-spec). + +2010-06-25 Tobias Burnus <burnus@net-b.de> + + * intrinsic.h (gfc_check_selected_real_kind, + gfc_simplify_selected_real_kind): Update prototypes. + * intrinsic.c (add_functions): Add radix support to + selected_real_kind. + * check.c (gfc_check_selected_real_kind): Ditto. + * simplify.c (gfc_simplify_selected_real_kind): Ditto. + * trans-decl.c (gfc_build_intrinsic_function_decls): + Change call from selected_real_kind to selected_real_kind2008. + * intrinsic.texi (SELECTED_REAL_KIND): Update for radix. + (PRECISION, RANGE, RADIX): Add cross @refs. + +2010-06-25 Tobias Burnus <burnus@net-b.de> + + * decl.c (gfc_match_entry): Mark ENTRY as GFC_STD_F2008_OBS. + * gfortran.texi (_gfortran_set_options): Update for + GFC_STD_F2008_OBS addition. + * libgfortran.h: Add GFC_STD_F2008_OBS. + * options.c (set_default_std_flags, gfc_handle_option): Handle + GFC_STD_F2008_OBS. + io.c (check_format): Fix allow_std check. + +2010-06-25 Tobias Burnus <burnus@net-b.de> + + * decl.c (gfc_match_entry): Allow END besides + END SUBROUTINE/END FUNCTION for contained procedures. + +2010-06-25 Tobias Burnus <burnus@net-b.de> + + * parse.c (next_free, next_fixed): Allow ";" as first character. + +2010-06-24 Tobias Burnus <burnus@net-b.de> + + PR fortran/44614 + * decl.c (variable_decl): Fix IMPORT diagnostic for CLASS. + +2010-06-22 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44616 + * resolve.c (resolve_fl_derived): Avoid checking for abstract on class + containers. + +2010-06-21 Tobias Burnus <burnus@net-b.de> + + PR fortran/40632 + * interface.c (compare_parameter): Add gfc_is_simply_contiguous + checks. + * symbol.c (gfc_add_contiguous): New function. + (gfc_copy_attr, check_conflict): Handle contiguous attribute. + * decl.c (match_attr_spec): Ditto. + (gfc_match_contiguous): New function. + * resolve.c (resolve_fl_derived, resolve_symbol): Handle + contiguous. + * gfortran.h (symbol_attribute): Add contiguous. + (gfc_is_simply_contiguous): Add prototype. + (gfc_add_contiguous): Add prototype. + * match.h (gfc_match_contiguous): Add prototype. + * parse.c (decode_specification_statement, + decode_statement): Handle contiguous attribute. + * expr.c (gfc_is_simply_contiguous): New function. + * dump-parse-tree.c (show_attr): Handle contiguous. + * module.c (ab_attribute, attr_bits, mio_symbol_attribute): + Ditto. + * trans-expr.c (gfc_add_interface_mapping): Copy + attr.contiguous. + * trans-array.c (gfc_conv_descriptor_stride_get, + gfc_conv_array_parameter): Handle contiguous arrays. + * trans-types.c (gfc_build_array_type, gfc_build_array_type, + gfc_sym_type, gfc_get_derived_type, gfc_get_array_descr_info): + Ditto. + * trans.h (gfc_array_kind): Ditto. + * trans-decl.c (gfc_get_symbol_decl): Ditto. + +2010-06-20 Joseph Myers <joseph@codesourcery.com> + + * options.c (gfc_handle_option): Don't handle N_OPTS. + +2010-06-19 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44584 + * resolve.c (resolve_fl_derived): Reverse ordering of conditions + to avoid ICE. + +2010-06-18 Tobias Burnus <burnus@net-b.de> + + PR fortran/44556 + * resolve.c (resolve_allocate_deallocate): Properly check + part-refs in stat=/errmsg= for invalid use. + +2010-06-17 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44558 + * resolve.c (resolve_typebound_function,resolve_typebound_subroutine): + Return directly in case of an error. + +2010-06-16 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44549 + * gfortran.h (gfc_get_typebound_proc): Modified Prototype. + * decl.c (match_procedure_in_type): Give a unique gfc_typebound_proc + structure to each procedure in a procedure list. + * module.c (mio_typebound_proc): Add NULL argument to + 'gfc_get_typebound_proc'. + * symbol.c (gfc_get_typebound_proc): Add a new argument, which is used + to initialize the new structure. + +2010-06-15 Janus Weil <janus@gcc.gnu.org> + + PR fortran/43388 + * gfortran.h (gfc_expr): Add new member 'mold'. + * match.c (gfc_match_allocate): Implement the MOLD tag. + * resolve.c (resolve_allocate_expr): Ditto. + * trans-stmt.c (gfc_trans_allocate): Ditto. + +2010-06-15 Jakub Jelinek <jakub@redhat.com> + + PR fortran/44536 + * trans-openmp.c (gfc_omp_predetermined_sharing): Don't return + OMP_CLAUSE_DEFAULT_SHARED for artificial vars with + GFC_DECL_SAVED_DESCRIPTOR set. + (gfc_omp_report_decl): New function. + * trans.h (gfc_omp_report_decl): New prototype. + * f95-lang.c (LANG_HOOKS_OMP_REPORT_DECL): Redefine. + +2010-06-13 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/31588 + PR fortran/43954 + * gfortranspec.c (lang_specific_driver): Removed deprecation + warning for -M. + * lang.opt: Add options -M, -MM, -MD, -MMD, -MF, -MG, -MP, -MT, -MQ. + * lang-specs.h (CPP_FORWARD_OPTIONS): Add -M* options. + * cpp.h (gfc_cpp_makedep): New. + (gfc_cpp_add_dep): New. + (gfc_cpp_add_target): New. + * cpp.c (gfc_cpp_option): Add deps* members. + (gfc_cpp_makedep): New. + (gfc_cpp_add_dep): New. + (gfc_cpp_add_target): New. + (gfc_cpp_init_options): Initialize new options. + (gfc_cpp_handle_option): Handle new options. + (gfc_cpp_post_options): Map new options to libcpp-options. + (gfc_cpp_init): Handle deferred -MQ and -MT options. + (gfc_cpp_done): If requested, write dependencies to file. + * module.c (gfc_dump_module): Add a module filename as target. + * scanner.c (open_included_file): New parameter system; add the + included file as dependency. + (gfc_open_included_file): Add the included file as dependency. + (gfc_open_intrinsic_module): Likewise. + * invoke.texi: Removed deprecation warning for -M. + * gfortran.texi: Removed Makefile-dependencies project. + +2010-06-12 Daniel Franke <franke.daniel@gmail.com> + + * resolve.c (resolve_global_procedure): Improved checking if an + explicit interface is required. + +2010-06-12 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * trans-decl.c (gfc_build_intrinsic_function_decls): Fix + return type. + * trans-intrinsic.c (gfc_conv_intrinsic_fdate): Fix argument type. + (gfc_conv_intrinsic_ttynam): Likewise. + (gfc_conv_intrinsic_trim): Likewise. + +2010-06-12 Janus Weil <janus@gcc.gnu.org> + + PR fortran/40117 + * decl.c (match_procedure_in_type): Allow procedure lists (F08). + +2010-06-11 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * trans-intrinsic.c (gfc_build_intrinsic_lib_fndecls): Fix comment. + +2010-06-11 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * mathbuiltins.def: Add builtins that do not directly correspond + to a Fortran intrinsic, with new macro OTHER_BUILTIN. + * f95-lang.c (gfc_init_builtin_functions): Define OTHER_BUILTIN. + * trans-intrinsic.c (gfc_intrinsic_map_t): Remove + code_{r,c}{4,8,10,16} fields. Add + {,complex}{float,double,long_double}_built_in fields. + (gfc_intrinsic_map): Adjust definitions of DEFINE_MATH_BUILTIN, + DEFINE_MATH_BUILTIN_C and LIB_FUNCTION accordingly. Add + definition of OTHER_BUILTIN. + (real_compnt_info): Remove unused struct. + (builtin_decl_for_precision, builtin_decl_for_float_kind): New + functions. + (build_round_expr): Call builtin_decl_for_precision instead of + series of if-else. + (gfc_conv_intrinsic_aint): Call builtin_decl_for_float_kind + instead of a switch. + (gfc_build_intrinsic_lib_fndecls): Match + {real,complex}{4,8,10,16}decl into the C-style built_in_decls. + (gfc_get_intrinsic_lib_fndecl): Do not hardcode floating-point + kinds. + (gfc_conv_intrinsic_lib_function): Go through all the extended + gfc_intrinsic_map. + (gfc_trans_same_strlen_check): Call builtin_decl_for_float_kind + instead of a switch. + (gfc_conv_intrinsic_abs): Likewise. + (gfc_conv_intrinsic_mod): Likewise. + (gfc_conv_intrinsic_sign): Likewise. + (gfc_conv_intrinsic_fraction): Likewise. + (gfc_conv_intrinsic_nearest): Likewise. + (gfc_conv_intrinsic_spacing): Likewise. + (gfc_conv_intrinsic_rrspacing): Likewise. + (gfc_conv_intrinsic_scale): Likewise. + (gfc_conv_intrinsic_set_exponent): Likewise. + +2010-06-11 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/42051 + PR fortran/43896 + * trans-expr.c (gfc_conv_derived_to_class): Handle array-valued + functions with CLASS formal arguments. + +2010-06-10 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44207 + * resolve.c (conformable_arrays): Handle allocatable components. + +2010-06-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/38273 + * gfortran.texi: Document that Cray pointers cannot be function + results. + +2010-06-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/36234 + * gfortran.texi: Document lack of support for syntax + "complex FUNCTION name*16()", and existence of alternative + legacy syntax "complex*16 FUNCTION name()". + +2010-06-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/43032 + * intrinsic.texi (FLUSH): Note the difference between FLUSH and + POSIX's fsync(), and how to call the latter from Fortran code. + +2010-06-10 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/44457 + * interface.c (compare_actual_formal): Reject actual arguments with + array subscript passed to ASYNCHRONOUS dummys. + +2010-06-10 Daniel Kraft <d@domob.eu> + + PR fortran/38936 + * gfortran.h (enum gfc_statement): Add ST_ASSOCIATE, ST_END_ASSOCIATE. + (struct gfc_symbol): New field `assoc'. + (struct gfc_association_list): New struct. + (struct gfc_code): New struct `block' in union, move `ns' there + and add association list. + (gfc_free_association_list): New method. + (gfc_has_vector_subscript): Made public; + * match.h (gfc_match_associate): New method. + * parse.h (enum gfc_compile_state): Add COMP_ASSOCIATE. + * decl.c (gfc_match_end): Handle ST_END_ASSOCIATE. + * interface.c (gfc_has_vector_subscript): Made public. + (compare_actual_formal): Rename `has_vector_subscript' accordingly. + * match.c (gfc_match_associate): New method. + (gfc_match_select_type): Change reference to gfc_code's `ns' field. + * primary.c (match_variable): Don't allow names associated to expr here. + * parse.c (decode_statement): Try matching ASSOCIATE statement. + (case_exec_markers, case_end): Add ASSOCIATE statement. + (gfc_ascii_statement): Hande ST_ASSOCIATE and ST_END_ASSOCIATE. + (parse_associate): New method. + (parse_executable): Handle ST_ASSOCIATE. + (parse_block_construct): Change reference to gfc_code's `ns' field. + * resolve.c (resolve_select_type): Ditto. + (resolve_code): Ditto. + (resolve_block_construct): Ditto and add comment. + (resolve_select_type): Set association list in generated BLOCK to NULL. + (resolve_symbol): Resolve associate names. + * st.c (gfc_free_statement): Change reference to gfc_code's `ns' field + and free association list. + (gfc_free_association_list): New method. + * symbol.c (gfc_new_symbol): NULL new field `assoc'. + * trans-stmt.c (gfc_trans_block_construct): Change reference to + gfc_code's `ns' field. + +2010-06-10 Kai Tietz <kai.tietz@onevision.com> + + * error.c (error_print): Pre-initialize loc by NULL. + * openmp.c (resolve_omp_clauses): Add explicit + braces to avoid ambigous else. + * array.c (match_subscript): Pre-initialize m to MATCH_ERROR. + +2010-06-10 Gerald Pfeifer <gerald@pfeifer.com> + + * gfc-internals.texi: Move to GFDL 1.3. + * gfortran.texi: Ditto. + * intrinsic.texi: Ditto. + * invoke.texi: Ditto. + +2010-06-09 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/44347 + * check.c (gfc_check_selected_real_kind): Verify that the + actual arguments are scalar. + +2010-06-09 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/44359 + * intrinsic.c (gfc_convert_type_warn): Further improve -Wconversion. + +2010-06-09 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44430 + * dump-parse-tree.c (show_symbol): Avoid infinite loop. + +2010-06-09 Steven G. Kargl <kargl@gcc.gnu.org> + + * fortran/symbol.c (check_conflict): Remove an invalid conflict check. + +2010-06-09 Steven G. Kargl <kargl@gcc.gnu.org> + + * fortran/intrinsic.c (add_functions): Change gfc_check_btest, + gfc_check_ibclr, and gfc_check_ibset to gfc_check_bitfcn. + * fortran/intrinsic.h: Remove prototypes for gfc_check_btest, + gfc_check_ibclr, and gfc_check_ibset. Add prototype for + gfc_check_bitfcn. + * fortran/check.c (nonnegative_check, less_than_bitsize1, + less_than_bitsize2): New functions. + (gfc_check_btest): Renamed to gfc_check_bitfcn. Use + nonnegative_check and less_than_bitsize1. + (gfc_check_ibclr, gfc_check_ibset): Removed. + (gfc_check_ibits,gfc_check_mvbits): Use nonnegative_check and + less_than_bitsize1. + +2010-06-09 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44211 + * resolve.c (resolve_typebound_function,resolve_typebound_subroutine): + Resolve references. + +2010-06-09 Kai Tietz <kai.tietz@onevision.com> + + * resolve.c (resolve_deallocate_expr): Avoid warning + about possible use of iunitialized sym. + (resolve_allocate_expr): Pre-initialize sym by NULL. + +2010-06-09 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/43040 + * f95-lang.c (gfc_init_builtin_functions): Remove comment. + +2010-06-08 Laurynas Biveinis <laurynas.biveinis@gmail.com> + + * trans-types.c (gfc_get_nodesc_array_type): Use typed GC + allocation. + (gfc_get_array_type_bounds): Likewise. + + * trans-decl.c (gfc_allocate_lang_decl): Likewise. + (gfc_find_module): Likewise. + + * f95-lang.c (pushlevel): Likewise. + + * trans.h (struct lang_type): Add variable_size GTY option. + (struct lang_decl): Likewise. + +2010-06-08 Tobias Burnus <burnus@net-b.de> + + PR fortran/44446 + * symbol.c (check_conflict): Move protected--external/procedure check ... + * resolve.c (resolve_select_type): ... to the resolution stage. + +2010-06-07 Tobias Burnus <burnus@net-b.de> + + * options.c (gfc_handle_option): Fix -fno-recursive. + +2010-06-07 Tobias Burnus <burnus@net-b.de> + + * gfc-internals.texi (copyrights-gfortran): Fix copyright year format. + * gfortran.texi (copyrights-gfortran): Ditto. + +2010-06-07 Joseph Myers <joseph@codesourcery.com> + + * lang.opt (fshort-enums): Define using Var and VarExists. + * options.c (gfc_handle_option): Don't set flag_short_enums here. + +2010-06-05 Paul Thomas <pault@gcc.gnu.org> + Janus Weil <janus@gcc.gnu.org> + + PR fortran/43945 + * resolve.c (get_declared_from_expr): Move to before + resolve_typebound_generic_call. Make new_ref and class_ref + ignorable if set to NULL. + (resolve_typebound_generic_call): Once we have resolved the + generic call, check that the specific instance is that which + is bound to the declared type. + (resolve_typebound_function,resolve_typebound_subroutine): Avoid + freeing 'class_ref->next' twice. + +2010-06-05 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/43895 + * trans-array.c (structure_alloc_comps): Dereference scalar + 'decl' if it is a REFERENCE_TYPE. Tidy expressions containing + TREE_TYPE (decl). + +2010-06-04 Joseph Myers <joseph@codesourcery.com> + + * gfortranspec.c (append_arg, lang_specific_driver): Use + GCC-specific formats in diagnostics. + +2010-06-02 Tobias Burnus <burnus@net-b.de> + + PR fortran/44360 + * parse.c (gfc_fixup_sibling_symbols): Do not "fix" use-associated + symbols. + +2010-06-01 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/44371 + * match.c (gfc_match_stopcode): Move gfc_match_eos call inside + condition block. + +2010-05-31 Steven G. Kargl <kargl@gcc.gnu.org> + + * fortran/gfortran.texi: Fix typos in description of variable-format- + expressions. + +2010-05-31 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/36928 + * dependency.c (gfc_check_section_vs_section): Check + for interleaving array assignments without conflicts. + +2010-05-30 Janus Weil <janus@gcc.gnu.org> + + * gcc/fortran/gfortran.h (CLASS_DATA): New macro for accessing the + $data component of a class container. + * gcc/fortran/decl.c (attr_decl1): Use macro CLASS_DATA. + * gcc/fortran/expr.c (gfc_check_pointer_assign,gfc_check_assign_symbol, + gfc_has_ultimate_allocatable,gfc_has_ultimate_pointer): Ditto. + * gcc/fortran/interface.c (matching_typebound_op): Ditto. + * gcc/fortran/match.c (gfc_match_allocate, gfc_match_deallocate): Ditto. + * gcc/fortran/parse.c (parse_derived): Ditto. + * gcc/fortran/primary.c (gfc_match_varspec, gfc_variable_attr, + gfc_expr_attr): Ditto. + * gcc/fortran/resolve.c (resolve_structure_cons, find_array_spec, + resolve_deallocate_expr, resolve_allocate_expr, resolve_select_type, + resolve_fl_var_and_proc, resolve_typebound_procedure, + resolve_fl_derived): Ditto. + * gcc/fortran/symbol.c (gfc_type_compatible): Restructured. + * gcc/fortran/trans-array.c (structure_alloc_comps): Use macro + CLASS_DATA. + * gcc/fortran/trans-decl.c (gfc_get_symbol_decl, + gfc_trans_deferred_vars): Ditto. + * gcc/fortran/trans-stmt.c (gfc_trans_allocate): Ditto. + +2010-05-28 Tobias Burnus <burnus@net-b.de> + + * options.c (gfc_handle_option): Fix handling of -fno-whole-file. + +2010-05-28 Joseph Myers <joseph@codesourcery.com> + + * gfortranspec.c (append_arg, lang_specific_driver): Use + fatal_error instead of fatal. Use warning instead of fprintf for + warnings. + +2010-05-28 Joseph Myers <joseph@codesourcery.com> + + * cpp.c (gfc_cpp_init_0): Use xstrerror instead of strerror. + * module.c (write_char, gfc_dump_module, gfc_use_module): Use + xstrerror instead of strerror. + +2010-05-26 Joseph Myers <joseph@codesourcery.com> + + * cpp.c (cb_cpp_error): Save and restore + global_dc->warn_system_headers, not variable warn_system_headers. + +2010-05-26 Steven Bosscher <steven@gcc.gnu.org> + + * fortran/f95-lang.c: Do not include libfuncs.h, expr.h, and except.h. + +2010-05-26 Steven Bosscher <steven@gcc.gnu.org> + + * trans-common.c: Do not include rtl.h, include output.h instead. + * trans-decl.c: Likewise. + +2010-05-26 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/40011 + * resolve.c (resolve_global_procedure): Resolve the gsymbol's + namespace before trying to reorder the gsymbols. + +2010-05-25 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/30668 + PR fortran/31346 + PR fortran/34260 + * resolve.c (resolve_global_procedure): Add check for global + procedures with implicit interfaces and assumed-shape or optional + dummy arguments. Verify that function return type, kind and string + lengths match. + +2010-05-21 Tobias Burnus <burnus@net-b.de> + + * gfortran.h: Do not include system.h. + * bbt.c: Include system.h. + * data.c: Ditto. + * dependency.c: Ditto. + * dump-parse-tree.c: Ditto. + * arith.h: Do not include gfortran.h. + * constructor.h: Do not include gfortran.h and splay-tree.h. + * match.h: Do not include gfortran.h. + * parse.h: Ditto. + * target-memory.h: Ditto. + * openmp.c: Do not include toplev.h and target.h. + * trans-stmt.c: Ditto not include toplev.h. + * primary.c: Ditto. + * trans-common.c: Tell why toplev.h is needed. And + do not include target.h. + * trans-expr.c: Tell why toplev.h is needed. + * trans-array.c: Ditto. + * trans-openmp.c: Ditto. + * trans-const.c: Ditto. + * trans.c: Ditto. + * trans-types.c: Ditto. + * trans-io.c: Ditto. + * trans-decl.c: Ditto. + * scanner.c: Ditto. + * convert.c: Ditto. + * trans-intrinsic.c: Ditto. + * options.c: Ditto. + +2010-05-22 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/43851 + * match.c (gfc_match_stopcode): Use gfc_match_init_expr. Go to cleanup + before returning MATCH_ERROR. Add check for scalar. Add check for + default integer kind. + +2010-05-22 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44212 + * match.c (gfc_match_select_type): On error jump back out of the local + namespace. + * parse.c (parse_derived): Defer creation of vtab symbols to resolution + stage, more precisely to ... + * resolve.c (resolve_fl_derived): ... this place. + +2010-05-22 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44213 + * resolve.c (ensure_not_abstract): Allow abstract types with + non-abstract ancestors. + +2010-05-21 Steven Bosscher <steven@gcc.gnu.org> + + * trans-const.c: Include realmpfr.h. + * Make-lang.in: Update dependencies. + +2010-05-21 Steven Bosscher <steven@gcc.gnu.org> + + * trans-const.c, trans-types.c, trans-intrinsic.c: + Clean up redundant includes. + +2010-05-20 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/38407 + * lang.opt (Wunused-dummy-argument): New option. + * gfortran.h (gfc_option_t): Add warn_unused_dummy_argument. + * options.c (gfc_init_options): Disable warn_unused_dummy_argument. + (set_Wall): Enable warn_unused_dummy_argument. + (gfc_handle_option): Set warn_unused_dummy_argument according to + command line. + * trans-decl.c (generate_local_decl): Separate warnings about + unused variables and unused dummy arguments. + * invoke.texi: Documented new option. + +2010-05-20 Steven Bosscher <steven@gcc.gnu.org> + + * trans-expr.c: Do not include convert.h, ggc.h, real.h, and gimple.h. + (gfc_conv_string_tmp): Do not assert type comparibilty. + * trans-array.c: Do not include gimple.h, ggc.h, and real.h. + (gfc_conv_expr_descriptor): Remove assert. + * trans-common.c: Clarify why rtl.h and tm.h are included. + * trans-openmp.c: Do not include ggc.h and real.h. + Explain why gimple.h is included. + * trans-const.c: Do not include ggc.h. + * trans-stmt.c: Do not include gimple.h, ggc.h, and real.h. + * trans.c: Do not include ggc.h and real.h. + Explain why gimple.h is included. + * trans-types.c: Do not include tm.h. Explain why langhooks.h + and dwarf2out.h are included. + * trans-io.c: Do not include gimple.h and real.h. + * trans-decl.c: Explain why gimple.h, tm.h, and rtl.h are included. + * trans-intrinsic.c: Do not include gimple.h. Explain why tm.h + is included. + +2010-05-20 Tobias Burnus <burnus@net-b.de> + + * options.c (gfc_init_options,gfc_post_options): Enable + flag_associative_math by default. + +2010-05-19 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/43851 + * trans-stmt.c (gfc_trans_stop): Add generation of call to + gfortran_error_stop_numeric. Fix up some whitespace. Use stop_string for + blank STOP, handling a null expression. (gfc_trans_pause): Use + pause_string for blank PAUSE. + * trans.h: Add external function declaration for error_stop_numeric. + * trans-decl.c (gfc_build_builtin_function_decls): Add the building of + the declaration for the library call. Adjust whitespaces. + * match.c (gfc_match_stopcode): Remove use of the actual stop code to + signal no stop code. Match the expression following the stop and pass + that to the translators. Remove the old use of digit matching. Add + checks that the stop_code expression is INTEGER or CHARACTER, constant, + and if CHARACTER, default character KIND. + +2010-05-19 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/44055 + * lang.opt (Wconversion-extra): New option. + * gfortran.h (gfc_option_t): Add warn_conversion_extra. + * options.c (gfc_init_options): Disable -Wconversion-extra by default. + (set_Wall): Enable -Wconversion. + (gfc_handle_option): Set warn_conversion_extra. + * intrinsic.c (gfc_convert_type_warn): Ignore kind conditions + introduced for -Wconversion if -Wconversion-extra is present. + * invoke.texi: Add -Wconversion to -Wall; document new behaviour of + -Wconversion; document -Wconversion-extra. + +2010-05-19 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/42360 + * gfortran.h (gfc_has_default_initializer): New. + * expr.c (gfc_has_default_initializer): New. + * resolve.c (has_default_initializer): Removed, use + gfc_has_default_initializer() instead. Updated all callers. + * trans-array.c (has_default_initializer): Removed, use + gfc_has_default_initializer() instead. Updated all callers. + * trans-decl.c (generate_local_decl): Do not check the + first component only to check for initializers, but use + gfc_has_default_initializer() instead. + +2010-05-19 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/38404 + * primary.c (match_string_constant): Move start_locus just inside + the string. + * data.c (create_character_intializer): Clarified truncation warning. + +2010-05-19 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/34505 + * intrinsic.h (gfc_check_float): New prototype. + (gfc_check_sngl): New prototype. + * check.c (gfc_check_float): New. + (gfc_check_sngl): New. + * intrinsic.c (add_functions): Moved DFLOAT from aliasing DBLE + to be a specific for REAL. Added check routines for FLOAT, DFLOAT + and SNGL. + * intrinsic.texi: Removed individual nodes of FLOAT, DFLOAT and SNGL, + added them to the list of specifics of REAL instead. + +2010-05-17 Janus Weil <janus@gcc.gnu.org> + + PR fortran/43990 + * trans-expr.c (gfc_conv_structure): Remove unneeded and buggy code. + This is now handled via 'gfc_class_null_initializer'. + +2010-05-17 Janus Weil <janus@gcc.gnu.org> + + * class.c (gfc_add_component_ref,gfc_class_null_initializer, + gfc_build_class_symbol,add_proc_component,add_proc_comps, + add_procs_to_declared_vtab1,copy_vtab_proc_comps, + add_procs_to_declared_vtab,add_generic_specifics, + add_generics_to_declared_vtab,gfc_find_derived_vtab, + find_typebound_proc_uop,gfc_find_typebound_proc, + gfc_find_typebound_user_op,gfc_find_typebound_intrinsic_op, + gfc_get_tbp_symtree): Moved here from other places. + * expr.c (gfc_add_component_ref,gfc_class_null_initializer): Move to + class.c. + * gfortran.h (gfc_build_class_symbol,gfc_find_derived_vtab, + gfc_find_typebound_proc,gfc_find_typebound_user_op, + gfc_find_typebound_intrinsic_op,gfc_get_tbp_symtree, + gfc_add_component_ref, gfc_class_null_initializer): Moved to class.c. + * Make-lang.in: Add class.o. + * symbol.c (gfc_build_class_symbol,add_proc_component,add_proc_comps, + add_procs_to_declared_vtab1,copy_vtab_proc_comps, + add_procs_to_declared_vtab,add_generic_specifics, + add_generics_to_declared_vtab,gfc_find_derived_vtab, + find_typebound_proc_uop,gfc_find_typebound_proc, + gfc_find_typebound_user_op,gfc_find_typebound_intrinsic_op, + gfc_get_tbp_symtree): Move to class.c. + +2010-05-17 Nathan Froyd <froydnj@codesourcery.com> + + * trans-types.c (gfc_init_types): Use build_function_type_list. + (gfc_get_ppc_type): Likewise. + * trans-decl.c (gfc_generate_constructors): Likewise. + * f95-lang.c (build_builtin_fntypes): Likewise. + (gfc_init_builtin_functions): Likewise. + (DEF_FUNCTION_TYPE_0): Likewise. + (DEF_FUNCTION_TYPE_1): Likewise. + (DEF_FUNCTION_TYPE_2): Likewise. + (DEF_FUNCTION_TYPE_3): Likewise. + (DEF_FUNCTION_TYPE_4): Likewise. + (DEF_FUNCTION_TYPE_5): Likewise. + (DEF_FUNCTION_TYPE_6): Likewise. + (DEF_FUNCTION_TYPE_7): Likewise. Use ARG7. + (DEF_FUNCTION_TYPE_VAR_0): Use build_varags_function_type_list. + +2010-05-17 Nathan Froyd <froydnj@codesourcery.com> + + * trans-array.c (gfc_trans_array_constructor_value): Use + build_constructor instead of build_constructor_from_list. + (gfc_build_constant_array_constructor): Likewise. + * trans-decl.c (create_main_function): Likewise. + * trans-stmt.c (gfc_trans_character_select): Likewise. + +2010-05-17 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44044 + * resolve.c (resolve_fl_var_and_proc): Move error messages here from ... + (resolve_fl_variable_derived): ... this place. + (resolve_symbol): Make sure function symbols (and their result + variables) are not resolved twice. + +2010-05-16 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/35779 + * array.c (match_array_list): Revert change from 2010-05-13. + +2010-05-16 Richard Guenther <rguenther@suse.de> + + * trans-decl.c (module_htab_decls_hash): Revert last change. + +2010-05-16 Richard Guenther <rguenther@suse.de> + + * trans-decl.c (module_htab_decls_hash): Use IDENTIFIER_HASH_VALUE. + +2010-05-16 Manuel López-Ibáñez <manu@gcc.gnu.org> + + * options.c (set_Wall): Remove special logic for Wuninitialized + without -O. + +2010-05-15 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44154 + PR fortran/42647 + * trans-decl.c (gfc_trans_deferred_vars): Modify ordering of + if branches. + +2010-05-15 Janus Weil <janus@gcc.gnu.org> + + PR fortran/43207 + PR fortran/43969 + * gfortran.h (gfc_class_null_initializer): New prototype. + * expr.c (gfc_class_null_initializer): New function to build a NULL + initializer for CLASS pointers. + * symbol.c (gfc_build_class_symbol): Modify internal naming of class + containers. Remove default NULL initialization of $data component. + * trans.c (gfc_allocate_array_with_status): Fix wording of an error + message. + * trans-expr.c (gfc_conv_initializer,gfc_trans_subcomponent_assign): + Use new function 'gfc_class_null_initializer'. + * trans-intrinsic.c (gfc_conv_allocated): Handle allocatable scalar + class variables. + +2010-05-14 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/44135 + * fortran/interface.c (get_sym_storage_size): Use signed instead of + unsigned mpz_get_?i routines. + +2010-05-14 Jakub Jelinek <jakub@redhat.com> + + * trans.c (trans_code): Set backend locus early. + * trans-decl.c (gfc_get_fake_result_decl): Use source location + of the function instead of current input_location. + +2010-05-13 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/35779 + * intrinsic.c (gfc_init_expr): Renamed to gfc_init_expr_flag. + Updated all usages. + * expr.c (init_flag): Removed; use gfc_init_expr_flag everywhere. + * array.c (match_array_list): Pass on gfc_init_expr_flag when matching + iterators. + +2010-05-13 Jakub Jelinek <jakub@redhat.com> + + PR fortran/44036 + * openmp.c (resolve_omp_clauses): Allow procedure pointers in clause + variable lists. + * trans-openmp.c (gfc_omp_privatize_by_reference): Don't privatize + by reference dummy procedures or non-dummy procedure pointers. + (gfc_omp_predetermined_sharing): Return + OMP_CLAUSE_DEFAULT_FIRSTPRIVATE for dummy procedures. + +2010-05-11 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/43711 + * openmp.c (gfc_match_omp_taskwait): Report unexpected characters + after OMP statement. + (gfc_match_omp_critical): Likewise. + (gfc_match_omp_flush): Likewise. + (gfc_match_omp_workshare): Likewise. + (gfc_match_omp_master): Likewise. + (gfc_match_omp_ordered): Likewise. + (gfc_match_omp_atomic): Likewise. + (gfc_match_omp_barrier): Likewise. + (gfc_match_omp_end_nowait): Likewise. + +2010-05-11 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/31820 + * resolve.c (validate_case_label_expr): Removed FIXME. + (resolve_select): Raise default warning on case labels out of range + of the case expression. + +2010-05-10 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/27866 + PR fortran/35003 + PR fortran/42809 + * intrinsic.c (gfc_convert_type_warn): Be more discriminative + about conversion warnings. + +2010-05-10 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44044 + * match.c (gfc_match_select_type): Move error message to + resolve_select_type. + * resolve.c (resolve_select_type): Error message moved here from + gfc_match_select_type. Correctly set type of temporary. + +2010-05-10 Richard Guenther <rguenther@suse.de> + + * trans-decl.c (gfc_build_library_function_decl): Split out + worker to ... + (build_library_function_decl_1): ... this new function. + Set a fnspec attribute if a specification was provided. + (gfc_build_library_function_decl_with_spec): New function. + (gfc_build_intrinsic_function_decls): Annotate internal_pack + and internal_unpack. + +2010-05-07 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/40728 + * intrinc.c (gfc_is_intrinsic): Do not prematurely mark symbol + as external. + +2010-05-07 Jason Merrill <jason@redhat.com> + + * trans-expr.c (gfc_conv_procedure_call): Rename nullptr to null_ptr + to avoid -Wc++-compat warning. + +2010-05-06 Manuel López-Ibáñez <manu@gcc.gnu.org> + + PR 40989 + * options.c (gfc_handle_option): Add argument kind. + * gfortran.h (gfc_handle_option): Update declaration. + +2010-05-06 Tobias Burnus <burnus@net-b.de> + + PR fortran/43985 + * trans-types.c (gfc_sym_type): Mark Cray pointees as + GFC_POINTER_TYPE_P. + +2010-05-05 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/32331 + * resolve.c (traverse_data_list): Rephrase error message for + non-constant bounds in data-implied-do. + +2010-05-05 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/24978 + * gfortran.h: Removed repeat count from constructor, removed + all usages. + * data.h (gfc_assign_data_value_range): Changed return value from + void to gfc_try. + * data.c (gfc_assign_data_value): Add location to constructor element. + (gfc_assign_data_value_range): Call gfc_assign_data_value() + for each element in range. Return early if an error was generated. + * resolve.c (check_data_variable): Stop early if range assignment + generated an error. + +2010-05-05 Janus Weil <janus@gcc.gnu.org> + + PR fortran/43696 + * resolve.c (resolve_fl_derived): Some fixes for class variables. + * symbol.c (gfc_build_class_symbol): Add separate class container for + class pointers. + +2010-05-03 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/43592 + * fortran/parse.c (parse_interface): Do not dereference a NULL pointer. + +2010-05-02 Tobias Burnus <burnus@net-b.de> + + PR fortran/18918 + * intrinsic.c (add_functions): Fix GFC_STD and add gfc_resolve_ calls + for lcobound, ucobound, image_index and this_image. + * intrinsic.h (gfc_resolve_lcobound, gfc_resolve_this_image, + gfc_resolve_image_index, gfc_resolve_ucobound): New prototypes. + * iresolve.c (gfc_resolve_lcobound, gfc_resolve_this_image, + gfc_resolve_image_index, gfc_resolve_ucobound, resolve_bound): New + functions. + (gfc_resolve_lbound, gfc_resolve_ubound): Use resolve_bound. + +2010-04-30 Tobias Burnus <burnus@net-b.de> + + PR fortran/18918 + PR fortran/43931 + * trans-types.c (gfc_get_array_descriptor_base): Fix index + calculation for array descriptor types. + +2010-04-29 Janus Weil <janus@gcc.gnu.org> + + PR fortran/43896 + * symbol.c (add_proc_component,copy_vtab_proc_comps): Remove + initializers for PPC members of the vtabs. + +2010-04-29 Janus Weil <janus@gcc.gnu.org> + + PR fortran/42274 + * symbol.c (add_proc_component,add_proc_comps): Correctly set the 'ppc' + attribute for all PPC members of the vtypes. + (copy_vtab_proc_comps): Copy the correct interface. + * trans.h (gfc_trans_assign_vtab_procs): Modified prototype. + * trans-expr.c (gfc_trans_assign_vtab_procs): Pass the derived type as + a dummy argument and make sure all PPC members of the vtab are + initialized correctly. + (gfc_conv_derived_to_class,gfc_trans_class_assign): Additional argument + in call to gfc_trans_assign_vtab_procs. + * trans-stmt.c (gfc_trans_allocate): Ditto. + +2010-04-29 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/43326 + * resolve.c (resolve_typebound_function): Renamed + resolve_class_compcall.Do all the detection of class references + here. + (resolve_typebound_subroutine): resolve_class_typebound_call + renamed. Otherwise same as resolve_typebound_function. + (gfc_resolve_expr): Call resolve_typebound_function. + (resolve_code): Call resolve_typebound_subroutine. + +2010-04-29 Janus Weil <janus@gcc.gnu.org> + + PR fortran/43492 + * resolve.c (resolve_typebound_generic_call): For CLASS methods + pass back the specific symtree name, rather than the target + name. + +2010-04-29 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/42353 + * resolve.c (resolve_structure_cons): Make the initializer of + the vtab component 'extends' the same type as the component. + +2010-04-29 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/42680 + * interface.c (check_interface1): Pass symbol name rather than NULL to + gfc_compare_interfaces.(gfc_compare_interfaces): Add assert to + trap MULL. (gfc_compare_derived_types): Revert previous change + incorporated incorrectly during merge from trunk, r155778. + * resolve.c (check_generic_tbp_ambiguity): Pass symbol name rather + than NULL to gfc_compare_interfaces. + * symbol.c (add_generic_specifics): Likewise. + +2010-02-29 Janus Weil <janus@gcc.gnu.org> + + PR fortran/42353 + * interface.c (gfc_compare_derived_types): Add condition for vtype. + * symbol.c (gfc_find_derived_vtab): Sey access to private. + (gfc_find_derived_vtab): Likewise. + * module.c (ab_attribute): Add enumerator AB_VTAB. + (mio_symbol_attribute): Use new attribute, AB_VTAB. + (check_for_ambiguous): Likewise. + +2010-04-29 Paul Thomas <pault@gcc.gnu.org> + Janus Weil <janus@gcc.gnu.org> + + PR fortran/41829 + * trans-expr.c (select_class_proc): Remove function. + (conv_function_val): Delete reference to previous. + (gfc_conv_derived_to_class): Add second argument to the call to + gfc_find_derived_vtab. + (gfc_conv_structure): Exclude proc_pointer components when + accessing $data field of class objects. + (gfc_trans_assign_vtab_procs): New function. + (gfc_trans_class_assign): Add second argument to the call to + gfc_find_derived_vtab. + * symbol.c (gfc_build_class_symbol): Add delayed_vtab arg and + implement holding off searching for the vptr derived type. + (add_proc_component): New function. + (add_proc_comps): New function. + (add_procs_to_declared_vtab1): New function. + (copy_vtab_proc_comps): New function. + (add_procs_to_declared_vtab): New function. + (void add_generic_specifics): New function. + (add_generics_to_declared_vtab): New function. + (gfc_find_derived_vtab): Add second argument to the call to + gfc_find_derived_vtab. Add the calls to + add_procs_to_declared_vtab and add_generics_to_declared_vtab. + * decl.c (build_sym, build_struct): Use new arg in calls to + gfc_build_class_symbol. + * gfortran.h : Add vtype bitfield to symbol_attr. Remove the + definition of struct gfc_class_esym_list. Modify prototypes + of gfc_build_class_symbol and gfc_find_derived_vtab. + * trans-stmt.c (gfc_trans_allocate): Add second argument to the + call to gfc_find_derived_vtab. + * module.c : Add the vtype attribute. + * trans.h : Add prototype for gfc_trans_assign_vtab_procs. + * resolve.c (resolve_typebound_generic_call): Add second arg + to pass along the generic name for class methods. + (resolve_typebound_call): The same. + (resolve_compcall): Use the second arg to carry the generic + name from the above. Remove the reference to class_esym. + (check_members, check_class_members, resolve_class_esym, + hash_value_expr): Remove functions. + (resolve_class_compcall, resolve_class_typebound_call): Modify + to use vtable rather than member by member calls. + (gfc_resolve_expr): Modify second arg in call to + resolve_compcall. + (resolve_select_type): Add second arg in call to + gfc_find_derived_vtab. + (resolve_code): Add second arg in call resolve_typebound_call. + (resolve_fl_derived): Exclude vtypes from check for late + procedure definitions. Likewise for checking of explicit + interface and checking of pass arg. + * iresolve.c (gfc_resolve_extends_type_of): Add second arg in + calls to gfc_find_derived_vtab. + * match.c (select_type_set_tmp): Use new arg in call to + gfc_build_class_symbol. + * trans-decl.c (gfc_get_symbol_decl): Complete vtable if + necessary. + * parse.c (endType): Finish incomplete classes. + +2010-04-28 Tobias Burnus <burnus@net-b.de> + + PR fortran/18918 + PR fortran/43919 + * simplify.c (simplify_cobound): Handle scalar coarrays. + +2010-04-27 Tobias Burnus <burnus@net-b.de> + + * gfc-internals.texi: Update copyright year. + * gfortran.texi: Ditto. + * invoke.texi: Ditto. + +2010-04-27 Tobias Burnus <burnus@net-b.de> + + PR fortran/18918 + * resolve.c (resolve_allocate_expr): Allow array coarrays. + * trans-types.h (gfc_get_array_type_bounds): Update prototype. + * trans-types.c (gfc_get_array_type_bounds, + gfc_get_array_descriptor_base): Add corank argument. + * trans-array.c (gfc_array_init_size): Handle corank. + (gfc_trans_create_temp_array, gfc_array_allocate, + gfc_conv_expr_descriptor): Add corank argument to call. + * trans-stmt.c (gfc_trans_pointer_assign_need_temp): Ditto. + +2010-04-24 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/30073 + PR fortran/43793 + * trans-array.c (gfc_trans_array_bound_check): Use TREE_CODE instead + of mucking with a tree directly. + +2010-04-24 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/43832 + * io.c (gfc_match_open): Remove branch to syntax error. Add call to + gfc_error with new error message. + +2010-04-24 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/43841 + PR fortran/43843 + * trans-expr.c (gfc_conv_expr): Supply an address expression for + GFC_SS_REFERENCE. + (gfc_conv_expr_reference): Call gfc_conv_expr and return for + GFC_SS_REFERENCE. + * trans-array.c (gfc_add_loop_ss_code): Store the value rather + than the address of a GFC_SS_REFERENCE. + * trans.h : Change comment on GFC_SS_REFERENCE. + +2010-04-22 Richard Guenther <rguenther@suse.de> + + PR fortran/43829 + * resolve.c (gfc_resolve_index): Wrap around ... + (gfc_resolve_index_1): ... this. Add parameter to allow + any integer kind index type. + (resolve_array_ref): Allow any integer kind for the start + index of an array ref. + +2010-04-21 Jakub Jelinek <jakub@redhat.com> + + PR fortran/43836 + * f95-lang.c (gfc_define_builtin): Set TREE_NOTHROW on + the decl. + +2010-04-20 Harald Anlauf <anlauf@gmx.de> + + * intrinsic.c (sort_actual): Remove 'is' in error message. + +2010-04-20 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/43227 + * resolve.c (resolve_fl_derived): If a component character + length has not been resolved, do so now. + (resolve_symbol): The same as above for a symbol character + length. + * trans-decl.c (gfc_create_module_variable): A 'length' decl is + not needed for a character valued, procedure pointer. + + PR fortran/43266 + * resolve.c (ensure_not_abstract_walker): If 'overriding' is + not found, return FAILURE rather than ICEing. + +2010-04-19 Jakub Jelinek <jakub@redhat.com> + + PR fortran/43339 + * openmp.c (gfc_resolve_do_iterator): Only make iteration vars for + sequential loops private in the innermost containing task region. + +2010-04-18 Eric Botcazou <ebotcazou@adacore.com> + + * f95-lang.c (gfc_init_decl_processing): Remove second argument in call + to build_common_tree_nodes. + +2010-04-17 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/31538 + * fortran/trans-array.c (gfc_conv_ss_startstride): Remove the use of + gfc_msg_bounds by using 'Array bound mismatch' directly. + (gfc_trans_dummy_array_bias): Remove the use of gfc_msg_bounds. Reword + error message to include the mismatch in the extent of array bound. + * fortran/trans.c: Remove gfc_msg_bounds. It is only used in one place. + * fortran/trans.h: Remove extern definition of gfc_msg_bounds. + +2010-04-17 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + * gfortran.texi: Update information on temporary file locations. + +2010-04-16 Jakub Jelinek <jakub@redhat.com> + + * trans-decl.c (gfc_build_qualified_array): Ensure + ubound.N and lbound.N artificial variable names don't appear + in debug info. + +2010-04-15 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/30073 + * trans-array.c (gfc_trans_array_bound_check): Eliminate a redundant + block of code. Set name to the variable associated with the descriptor. + +2010-04-15 Jakub Jelinek <jakub@redhat.com> + + * trans-decl.c (gfc_build_qualified_array): Clear DECL_IGNORED_P + on VAR_DECL LBOUND and/or UBOUND, even for -O1. + +2010-04-14 Steven G. Kargl <kargl@gcc.gnu.org> + + * intrinsic.texi: Add the missing specific name of intrinsic + procedure where the specific name is identical to the generic name. + Fix inconsistent or mismatch in the argument names in intrinsic + procedure descriptions. Add the SCALAR allocatable description to + ALLOCATED. + +2010-04-14 Tobias Burnus <burnus@net-b.de> + + PR fortran/18918 + * array.c (gfc_find_array_ref): Handle codimensions. + (gfc_match_array_spec,gfc_match_array_ref): Use gfc_fatal_error. + * check.c (is_coarray, dim_corank_check, gfc_check_lcobound, + gfc_check_image_index, gfc_check_this_image, gfc_check_ucobound): + New functions. + * gfortran.h (gfc_isym_id): Add GFC_ISYM_IMAGE_INDEX, + GFC_ISYM_LCOBOUND, GFC_ISYM_THIS_IMAGE, + GFC_ISYM_UCOBOUND. + * intrinsic.h (add_functions): Add this_image, image_index, + lcobound and ucobound intrinsics. + * intrinsic.c (gfc_check_lcobound,gfc_check_ucobound, + gfc_check_image_index, gfc_check_this_image, + gfc_simplify_image_index, gfc_simplify_lcobound, + gfc_simplify_this_image, gfc_simplify_ucobound): + New function prototypes. + * intrinsic.texi (IMAGE_INDEX, LCOBOUND, THIS_IMAGE + IMAGE_INDEX): Document new intrinsic functions. + * match.c (gfc_match_critical, sync_statement): Make -fcoarray=none + error fatal. + * simplify.c (simplify_bound_dim): Handle coarrays. + (simplify_bound): Update simplify_bound_dim call. + (gfc_simplify_num_images): Add -fcoarray=none check. + (simplify_cobound, gfc_simplify_lcobound, gfc_simplify_ucobound, + gfc_simplify_ucobound, gfc_simplify_ucobound): New functions. + +2010-04-14 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/43747 + * constructor.c: Fix typo in comment. + * expr.c (find_array_section): Add check for max array limit. + +2010-04-13 Iain Sandoe <iains@gcc.gnu.org> + + PR bootstrap/31400 + * gfortranspec.c (lookup_option): Check for -static and return + OPTION_static. + (lang_specific_driver): Break when OPTION_static is discovered. + +2010-04-12 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + * array.c (extract_element): Restore function from trunk. + (gfc_get_array_element): Restore function from trunk. + (gfc_expand_constructor): Restore check against + flag_max_array_constructor. + * constructor.c (node_copy_and_append): Delete unused. + * gfortran.h: Delete comment and extra include. + * constructor.h: Bump copyright and clean up TODO comments. + * resolve.c: Whitespace. + +2010-04-12 Daniel Franke <franke.daniel@gmail.com> + + * simplify.c (compute_dot_product): Replaced usage of ADVANCE macro + with direct access access to elements. Adjusted prototype, fixed all + callers. + (gfc_simplify_dot_product): Removed duplicate check for zero-sized + array. + (gfc_simplify_matmul): Removed usage of ADVANCE macro. + (gfc_simplify_spread): Removed workaround, directly insert elements + at a given array position. + (gfc_simplify_transpose): Likewise. + (gfc_simplify_pack): Replaced usage of ADVANCE macro with corresponding + function calls. + (gfc_simplify_unpack): Likewise. + +2010-04-12 Daniel Franke <franke.daniel@gmail.com> + + * simplify.c (only_convert_cmplx_boz): Renamed to ... + (convert_boz): ... this and moved to start of file. + (gfc_simplify_abs): Whitespace fix. + (gfc_simplify_acos): Whitespace fix. + (gfc_simplify_acosh): Whitespace fix. + (gfc_simplify_aint): Whitespace fix. + (gfc_simplify_dint): Whitespace fix. + (gfc_simplify_anint): Whitespace fix. + (gfc_simplify_and): Replaced if-gate by more common switch-over-type. + (gfc_simplify_dnint): Whitespace fix. + (gfc_simplify_asin): Whitespace fix. + (gfc_simplify_asinh): Moved creation of result-expr out of switch. + (gfc_simplify_atan): Likewise. + (gfc_simplify_atanh): Whitespace fix. + (gfc_simplify_atan2): Whitespace fix. + (gfc_simplify_bessel_j0): Removed ATTRIBUTE_UNUSED. + (gfc_simplify_bessel_j1): Likewise. + (gfc_simplify_bessel_jn): Likewise. + (gfc_simplify_bessel_y0): Likewise. + (gfc_simplify_bessel_y1): Likewise. + (gfc_simplify_bessel_yn): Likewise. + (gfc_simplify_ceiling): Reorderd statements. + (simplify_cmplx): Use convert_boz(), check for constant arguments. + Whitespace fix. + (gfc_simplify_cmplx): Use correct default kind. Removed check for + constant arguments. + (gfc_simplify_complex): Replaced if-gate. Removed check for + constant arguments. + (gfc_simplify_conjg): Whitespace fix. + (gfc_simplify_cos): Whitespace fix. + (gfc_simplify_cosh): Replaced if-gate by more common switch-over-type. + (gfc_simplify_dcmplx): Removed check for constant arguments. + (gfc_simplify_dble): Use convert_boz() and gfc_convert_constant(). + (gfc_simplify_digits): Whitespace fix. + (gfc_simplify_dim): Whitespace fix. + (gfc_simplify_dprod): Reordered statements. + (gfc_simplify_erf): Whitespace fix. + (gfc_simplify_erfc): Whitespace fix. + (gfc_simplify_epsilon): Whitespace fix. + (gfc_simplify_exp): Whitespace fix. + (gfc_simplify_exponent): Use convert_boz(). + (gfc_simplify_floor): Reorderd statements. + (gfc_simplify_gamma): Whitespace fix. + (gfc_simplify_huge): Whitespace fix. + (gfc_simplify_iand): Whitespace fix. + (gfc_simplify_ieor): Whitespace fix. + (simplify_intconv): Use gfc_convert_constant(). + (gfc_simplify_int): Use simplify_intconv(). + (gfc_simplify_int2): Reorderd statements. + (gfc_simplify_idint): Reorderd statements. + (gfc_simplify_ior): Whitespace fix. + (gfc_simplify_ishftc): Removed duplicate type check. + (gfc_simplify_len): Use range_check() instead of manual range check. + (gfc_simplify_lgamma): Removed ATTRIBUTE_UNUSED. Whitespace fix. + (gfc_simplify_log): Whitespace fix. + (gfc_simplify_log10): Whitespace fix. + (gfc_simplify_minval): Whitespace fix. + (gfc_simplify_maxval): Whitespace fix. + (gfc_simplify_mod): Whitespace fix. + (gfc_simplify_modulo): Whitespace fix. + (simplify_nint): Reorderd statements. + (gfc_simplify_not): Whitespace fix. + (gfc_simplify_or): Replaced if-gate by more common switch-over-type. + (gfc_simplify_radix): Removed unused result-variable. Whitespace fix. + (gfc_simplify_range): Removed unused result-variable. Whitespace fix. + (gfc_simplify_real): Use convert_boz() and gfc_convert_constant(). + (gfc_simplify_realpart): Whitespace fix. + (gfc_simplify_selected_char_kind): Removed unused result-variable. + (gfc_simplify_selected_int_kind): Removed unused result-variable. + (gfc_simplify_selected_real_kind): Removed unused result-variable. + (gfc_simplify_sign): Whitespace fix. + (gfc_simplify_sin): Whitespace fix. + (gfc_simplify_sinh): Replaced if-gate by more common switch-over-type. + (gfc_simplify_sqrt): Avoided goto by inlining check. Whitespace fix. + (gfc_simplify_tan): Replaced if-gate by more common switch-over-type. + (gfc_simplify_tanh): Replaced if-gate by more common switch-over-type. + (gfc_simplify_xor): Replaced if-gate by more common switch-over-type. + +2010-04-12 Daniel Franke <franke.daniel@gmail.com> + + * gfortran.h (gfc_start_constructor): Removed. + (gfc_get_array_element): Removed. + * array.c (gfc_start_constructor): Removed, use gfc_get_array_expr + instead. Fixed all callers. + (extract_element): Removed. + (gfc_expand_constructor): Temporarily removed check for + max-array-constructor. Will be re-introduced later if still required. + (gfc_get_array_element): Removed, use gfc_constructor_lookup_expr + instead. Fixed all callers. + * expr.c (find_array_section): Replaced manual lookup of elements + by gfc_constructor_lookup. + +2010-04-12 Daniel Franke <franke.daniel@gmail.com> + + * gfortran.h (gfc_get_null_expr): New prototype. + (gfc_get_operator_expr): New prototype. + (gfc_get_character_expr): New prototype. + (gfc_get_iokind_expr): New prototype. + * expr.c (gfc_get_null_expr): New. + (gfc_get_character_expr): New. + (gfc_get_iokind_expr): New. + (gfc_get_operator_expr): Moved here from matchexp.c (build_node). + * matchexp.c (build_node): Renamed and moved to + expr.c (gfc_get_operator_expr). Reordered arguments to match + other functions. Fixed all callers. + (gfc_get_parentheses): Use specific function to build expr. + * array.c (gfc_match_array_constructor): Likewise. + * arith.c (eval_intrinsic): Likewise. + (gfc_hollerith2int): Likewise. + (gfc_hollerith2real): Likewise. + (gfc_hollerith2complex): Likewise. + (gfc_hollerith2logical): Likewise. + * data.c (create_character_intializer): Likewise. + * decl.c (gfc_match_null): Likewise. + (enum_initializer): Likewise. + * io.c (gfc_match_format): Likewise. + (match_io): Likewise. + * match.c (gfc_match_nullify): Likewise. + * primary.c (match_string_constant): Likewise. + (match_logical_constant): Likewise. + (build_actual_constructor): Likewise. + * resolve.c (build_default_init_expr): Likewise. + * symbol.c (generate_isocbinding_symbol): Likewise. + (gfc_build_class_symbol): Likewise. + (gfc_find_derived_vtab): Likewise. + * simplify.c (simplify_achar_char): Likewise. + (gfc_simplify_adjustl): Likewise. + (gfc_simplify_adjustr): Likewise. + (gfc_simplify_and): Likewise. + (gfc_simplify_bit_size): Likewise. + (gfc_simplify_is_iostat_end): Likewise. + (gfc_simplify_is_iostat_eor): Likewise. + (gfc_simplify_isnan): Likewise. + (simplify_bound): Likewise. + (gfc_simplify_leadz): Likewise. + (gfc_simplify_len_trim): Likewise. + (gfc_simplify_logical): Likewise. + (gfc_simplify_maxexponent): Likewise. + (gfc_simplify_minexponent): Likewise. + (gfc_simplify_new_line): Likewise. + (gfc_simplify_null): Likewise. + (gfc_simplify_or): Likewise. + (gfc_simplify_precision): Likewise. + (gfc_simplify_repeat): Likewise. + (gfc_simplify_scan): Likewise. + (gfc_simplify_size): Likewise. + (gfc_simplify_trailz): Likewise. + (gfc_simplify_trim): Likewise. + (gfc_simplify_verify): Likewise. + (gfc_simplify_xor): Likewise. + * trans-io.c (build_dt): Likewise. + (gfc_new_nml_name_expr): Removed. + +2010-04-12 Daniel Franke <franke.daniel@gmail.com> + + * arith.h (gfc_constant_result): Removed prototype. + * constructor.h (gfc_build_array_expr): Removed prototype. + (gfc_build_structure_constructor_expr): Removed prototype. + * gfortran.h (gfc_int_expr): Removed prototype. + (gfc_logical_expr): Removed prototype. + (gfc_get_array_expr): New prototype. + (gfc_get_structure_constructor_expr): New prototype. + (gfc_get_constant_expr): New prototype. + (gfc_get_int_expr): New prototype. + (gfc_get_logical_expr): New prototype. + * arith.c (gfc_constant_result): Moved and renamed to + expr.c (gfc_get_constant_expr). Fixed all callers. + * constructor.c (gfc_build_array_expr): Moved and renamed to + expr.c (gfc_get_array_expr). Split gfc_typespec argument to type + and kind. Fixed all callers. + (gfc_build_structure_constructor_expr): Moved and renamed to + expr.c (gfc_get_structure_constructor_expr). Split gfc_typespec argument + to type and kind. Fixed all callers. + * expr.c (gfc_logical_expr): Renamed to ... + (gfc_get_logical_expr): ... this. Added kind argument. Fixed all callers. + (gfc_int_expr): Renamed to ... + (gfc_get_int_expr): ... this. Added kind and where arguments. Fixed all + callers. + (gfc_get_constant_expr): New. + (gfc_get_array_expr): New. + (gfc_get_structure_constructor_expr): New. + * simplify.c (int_expr_with_kind): Removed, callers use gfc_get_int_expr + instead. + +2010-04-12 Daniel Franke <franke.daniel@gmail.com> + + * constructor.h: New. + * constructor.c: New. + * Make-lang.in: Add new files to F95_PARSER_OBJS. + * arith.c (reducy_unary): Use constructor API. + (reduce_binary_ac): Likewise. + (reduce_binary_ca): Likewise. + (reduce_binary_aa): Likewise. + * check.c (gfc_check_pack): Likewise. + (gfc_check_reshape): Likewise. + (gfc_check_unpack): Likewise. + * decl.c (add_init_expr_to_sym): Likewise. + (build_struct): Likewise. + * dependency.c (gfc_check_dependency): Likewise. + (contains_forall_index_p): Likewise. + * dump-parse-tree.c (show_constructor): Likewise. + * expr.c (free_expr0): Likewise. + (gfc_copy_expr): Likewise. + (gfc_is_constant_expr): Likewise. + (simplify_constructor): Likewise. + (find_array_element): Likewise. + (find_component_ref): Likewise. + (find_array_section): Likewise. + (find_substring_ref): Likewise. + (simplify_const_ref): Likewise. + (scalarize_intrinsic_call): Likewise. + (check_alloc_comp_init): Likewise. + (gfc_default_initializer): Likewise. + (gfc_traverse_expr): Likewise. + * iresolve.c (check_charlen_present): Likewise. + (gfc_resolve_reshape): Likewise. + (gfc_resolve_transfer): Likewise. + * module.c (mio_constructor): Likewise. + * primary.c (build_actual_constructor): Likewise. + (gfc_match_structure_constructor): Likewise. + * resolve.c (resolve_structure_cons): Likewise. + * simplify.c (is_constant_array_expr): Likewise. + (init_result_expr): Likewise. + (transformational_result): Likewise. + (simplify_transformation_to_scalar): Likewise. + (simplify_transformation_to_array): Likewise. + (gfc_simplify_dot_product): Likewise. + (simplify_bound): Likewise. + (simplify_matmul): Likewise. + (simplify_minval_maxval): Likewise. + (gfc_simplify_pack): Likewise. + (gfc_simplify_reshape): Likewise. + (gfc_simplify_shape): Likewise. + (gfc_simplify_spread): Likewise. + (gfc_simplify_transpose): Likewise. + (gfc_simplify_unpack): Likewise.q + (gfc_convert_constant): Likewise. + (gfc_convert_char_constant): Likewise. + * target-memory.c (size_array): Likewise. + (encode_array): Likewise. + (encode_derived): Likewise. + (interpret_array): Likewise. + (gfc_interpret_derived): Likewise. + (expr_to_char): Likewise. + (gfc_merge_initializers): Likewise. + * trans-array.c (gfc_get_array_constructor_size): Likewise. + (gfc_trans_array_constructor_value): Likewise. + (get_array_ctor_strlen): Likewise. + (gfc_constant_array_constructor_p): Likewise. + (gfc_build_constant_array_constructor): Likewise. + (gfc_trans_array_constructor): Likewise. + (gfc_conv_array_initializer): Likewise. + * trans-decl.c (check_constant_initializer): Likewise. + * trans-expr.c (flatten_array_ctors_without_strlen): Likewise. + (gfc_apply_interface_mapping_to_cons): Likewise. + (gfc_trans_structure_assign): Likewise. + (gfc_conv_structure): Likewise. + * array.c (check_duplicate_iterator): Likewise. + (match_array_list): Likewise. + (match_array_cons_element): Likewise. + (gfc_match_array_constructor): Likewise. + (check_constructor_type): Likewise. + (check_constructor): Likewise. + (expand): Likewise. + (expand_constructor): Likewise. + (extract_element): Likewise. + (gfc_expanded_ac): Likewise. + (resolve_array_list): Likewise. + (gfc_resolve_character_array_constructor): Likewise. + (copy_iterator): Renamed to ... + (gfc_copy_iterator): ... this. + (gfc_append_constructor): Removed. + (gfc_insert_constructor): Removed unused function. + (gfc_get_constructor): Removed. + (gfc_free_constructor): Removed. + (qgfc_copy_constructor): Removed. + * gfortran.h (struct gfc_expr): Removed member 'con_by_offset'. + Removed all references. Replaced constructor list by splay-tree. + (struct gfc_constructor): Removed member 'next', moved 'offset' from + the inner struct, added member 'base'. + (gfc_append_constructor): Removed prototype. + (gfc_insert_constructor): Removed prototype. + (gfc_get_constructor): Removed prototype. + (gfc_free_constructor): Removed prototype. + (qgfc_copy_constructor): Removed prototype. + (gfc_copy_iterator): New prototype. + * trans-array.h (gfc_constant_array_constructor_p): Adjusted prototype. + +2010-04-10 Tobias Burnus <burnus@net-b.de> + + PR fortran/43591 + * expr.c (gfc_is_constant_expr, gfc_traverse_expr): Handle + proc-pointers and type-bound procedures. + (gfc_specification_expr): Check proc-pointers for pureness. + +2010-04-09 Iain Sandoe <iains@gcc.gnu.org> + + PR bootstrap/43684 + * gfortranspec.c (lang_specific_driver): Do not expose vars + only used by HAVE_LD_STATIC_DYNAMIC targets unless compiling + for such. + +2010-04-09 Tobias Burnus <burnus@net-b.de> + + PR fortran/18918 + * decl.c (variable_decl, match_attr_spec): Fix setting the array + spec. + * array.c (match_subscript,gfc_match_array_ref): Add coarray support. + * data.c (gfc_assign_data_value): Ditto. + * expr.c (gfc_check_pointer_assign): Add check for coarray constraint. + (gfc_traverse_expr): Traverse also through codimension expressions. + (gfc_is_coindexed, gfc_has_ultimate_allocatable, + gfc_has_ultimate_pointer): New functions. + * gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_STAR for coarrays. + (gfc_array_ref): Add codimen. + (gfc_array_ref): Add in_allocate. + (gfc_is_coindexed, gfc_has_ultimate_allocatable, + gfc_has_ultimate_pointer): Add prototypes. + * interface.c (compare_parameter, compare_actual_formal, + check_intents): Add coarray constraints. + * match.c (gfc_match_iterator): Add coarray constraint. + * match.h (gfc_match_array_ref): Update interface. + * primary.c (gfc_match_varspec): Handle codimensions. + * resolve.c (coarray_alloc, inquiry_argument): New static variables. + (check_class_members): Return gfc_try instead for error recovery. + (resolve_typebound_function,resolve_typebound_subroutine, + check_members): Handle return value of check_class_members. + (resolve_structure_cons, resolve_actual_arglist, resolve_function, + check_dimension, compare_spec_to_ref, resolve_array_ref, + resolve_ref, resolve_variable, gfc_resolve_expr, conformable_arrays, + resolve_allocate_expr, resolve_ordinary_assign): Add coarray + support. + * trans-array.c (gfc_conv_array_ref, gfc_walk_variable_expr): + Skip over coarray refs. + (gfc_array_allocate) Add support for references containing coindexes. + * trans-expr.c (gfc_add_interface_mapping): Copy coarray attribute. + (gfc_map_intrinsic_function): Ignore codimensions. + +2010-04-08 Bud Davis <bdavis9659@sbcglobal.net> + + PR fortran/28039 + * io.c (check_format_string): Added check for additional non + blank characters after the format string was successfully + parsed. + * io.c (check_format): Changed the error messages for positive + int required and period required to drop through the error logic + and report with gfc_error instead of gfc_error_now. Corrected + format postion for hollerith strings. + +2010-04-08 Tobias Burnus <burnus@net-b.de> + + * module.c (use_iso_fortran_env_module): Fix standard check. + +2010-04-07 Jakub Jelinek <jakub@redhat.com> + + * parse.c (parse_derived, parse_enum): Avoid set but not used + warning. + +2010-04-07 Janne Blomqvist <jb@gcc.gnu.org> + + PR fortran/40539 + * gfortran.texi: Add section about representation of + LOGICAL variables. + +2010-04-07 Simon Baldwin <simonb@google.com> + + * cpp.c (cb_cpp_error): Add warning reason argument, set a value + for diagnostic_override_option_index if CPP_W_WARNING_DIRECTIVE. + +2010-04-07 Richard Guenther <rguenther@suse.de> + + * options.c (gfc_init_options): Do not set. + +2010-04-06 Tobias Burnus <burnus@net-b.de> + + PR fortran/18918 + * array.c (gfc_match_array_spec): Add error for -fcoarray=none. + * match.c (gfc_match_critical, sync_statement): Ditto. + * gfortran.h (gfc_fcoarray): New enum. + (gfc_option_t): Use it. + * lang.opt (fcoarray): Add new flag. + * invoke.texi (fcoarray): Document it. + * options.c (gfc_init_options,gfc_handle_option): Handle -fcoarray=. + (gfc_handle_coarray_option): New function. + +2010-04-06 Tobias Burnus <burnus@net-b.de> + + PR fortran/18918 + * gfortran.h (gfc_array_spec): Add cotype. + * array.c (gfc_match_array_spec,gfc_set_array_spec): Use it + and defer error diagnostic. + * resolve.c (resolve_fl_derived): Add missing check. + (resolve_symbol): Add cotype/type check. + * parse.c (parse_derived): Fix setting of coarray_comp. + +2010-04-06 Tobias Burnus <burnus@net-b.de> + + PR fortran/18918 + * array.c (gfc_free_array_spec,gfc_resolve_array_spec, + match_array_element_spec,gfc_copy_array_spec, + gfc_compare_array_spec): Include corank. + (match_array_element_spec,gfc_set_array_spec): Support codimension. + * decl.c (build_sym,build_struct,variable_decl, + match_attr_spec,attr_decl1,cray_pointer_decl, + gfc_match_volatile): Add codimension. + (gfc_match_codimension): New function. + * dump-parse-tree.c (show_array_spec,show_attr): Support codimension. + * gfortran.h (symbol_attribute,gfc_array_spec): Ditto. + (gfc_add_codimension): New function prototype. + * match.h (gfc_match_codimension): New function prototype. + (gfc_match_array_spec): Update prototype + * match.c (gfc_match_common): Update gfc_match_array_spec call. + * module.c (MOD_VERSION): Bump. + (mio_symbol_attribute): Support coarray attributes. + (mio_array_spec): Add corank support. + * parse.c (decode_specification_statement,decode_statement, + parse_derived): Add coarray support. + * resolve.c (resolve_formal_arglist, was_declared, + is_non_constant_shape_array, resolve_fl_variable, + resolve_fl_derived, resolve_symbol): Add coarray support. + * symbol.c (check_conflict, gfc_add_volatile, gfc_copy_attr, + gfc_build_class_symbol): Add coarray support. + (gfc_add_codimension): New function. + +2010-04-06 Tobias Burnus <burnus@net-b.de> + + PR fortran/18918 + * iso-fortran-env.def: Add the integer parameters atomic_int_kind, + atomic_logical_kind, iostat_inquire_internal_unit, stat_locked, + stat_locked_other_image, stat_stopped_image and stat_unlocked of + Fortran 2008. + * intrinsic.texi (iso_fortran_env): Ditto. + * libgfortran.h (libgfortran_stat_codes): New enum. + * module.c (use_iso_fortran_env_module): Honour -std= when loading + constants from the intrinsic module. + 2010-04-06 Tobias Burnus <burnus@net-b.de> PR fortran/39997 @@ -107,16 +3708,16 @@ 2010-03-18 Paul Thomas <pault@gcc.gnu.org> - PR fortran/43039 - * trans-expr.c (conv_parent_component_references): Ensure that + PR fortran/43039 + * trans-expr.c (conv_parent_component_references): Ensure that 'dt' has a backend_decl. - PR fortran/43043 - * trans-expr.c (gfc_conv_structure): Ensure that the derived + PR fortran/43043 + * trans-expr.c (gfc_conv_structure): Ensure that the derived type has a backend_decl. - PR fortran/43044 - * resolve.c (resolve_global_procedure): Check that the 'cl' + PR fortran/43044 + * resolve.c (resolve_global_procedure): Check that the 'cl' structure is not NULL. 2010-03-18 Shujing Zhao <pearly.zhao@oracle.com> @@ -236,11 +3837,11 @@ and DECL_SIZE when encountering a larger common block and call layout_decl. -2010-02-24 Tobias Burnus <burnus@net-b.de> +2010-02-24 Tobias Burnus <burnus@net-b.de> PR fortran/43042 * trans-expr.c (gfc_conv_initializer): Call directly - gfc_conv_constant for C_NULL_(FUN)PTR. + gfc_conv_constant for C_NULL_(FUN)PTR. 2010-02-22 Paul Thomas <pault@gcc.gnu.org> @@ -528,8 +4129,8 @@ 2010-01-14 Paul Thomas <pault@gcc.gnu.org> - PR fortran/41478 - * trans-array.c (duplicate_allocatable): Static version of + PR fortran/41478 + * trans-array.c (duplicate_allocatable): Static version of gfc_duplicate_allocatable with provision to handle scalar components. New boolean argument to switch off call to malloc if true. @@ -558,7 +4159,7 @@ use associated but not generic is given an interface that includes itself, then make it generic. -2010-01-11 Joseph Myers <joseph@codesourcery.com> +2010-01-11 Joseph Myers <joseph@codesourcery.com> Shujing Zhao <pearly.zhao@oracle.com> PR translation/42469 diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in index b2bf52e70d3..8f72d320c2e 100644 --- a/gcc/fortran/Make-lang.in +++ b/gcc/fortran/Make-lang.in @@ -53,20 +53,20 @@ fortran-warn = $(STRICT_WARN) # from the parse tree to GENERIC F95_PARSER_OBJS = fortran/arith.o fortran/array.o fortran/bbt.o \ - fortran/check.o fortran/cpp.o fortran/data.o fortran/decl.o \ - fortran/dump-parse-tree.o fortran/error.o fortran/expr.o \ - fortran/interface.o fortran/intrinsic.o fortran/io.o fortran/iresolve.o \ - fortran/match.o fortran/matchexp.o fortran/misc.o fortran/module.o \ - fortran/openmp.o fortran/options.o fortran/parse.o fortran/primary.o \ - fortran/resolve.o fortran/scanner.o fortran/simplify.o fortran/st.o \ - fortran/symbol.o fortran/target-memory.o + fortran/check.o fortran/class.o fortran/constructor.o fortran/cpp.o \ + fortran/data.o fortran/decl.o fortran/dump-parse-tree.o fortran/error.o \ + fortran/expr.o fortran/interface.o fortran/intrinsic.o fortran/io.o \ + fortran/iresolve.o fortran/match.o fortran/matchexp.o fortran/misc.o \ + fortran/module.o fortran/openmp.o fortran/options.o fortran/parse.o \ + fortran/primary.o fortran/resolve.o fortran/scanner.o fortran/simplify.o \ + fortran/st.o fortran/symbol.o fortran/target-memory.o F95_OBJS = $(F95_PARSER_OBJS) $(FORTRAN_TARGET_OBJS) \ fortran/convert.o fortran/dependency.o fortran/f95-lang.o \ fortran/trans.o fortran/trans-array.o fortran/trans-common.o \ fortran/trans-const.o fortran/trans-decl.o fortran/trans-expr.o \ fortran/trans-intrinsic.o fortran/trans-io.o fortran/trans-openmp.o \ - fortran/trans-stmt.o fortran/trans-types.o + fortran/trans-stmt.o fortran/trans-types.o fortran/frontend-passes.o fortran_OBJS = $(F95_OBJS) gfortranspec.o @@ -78,7 +78,7 @@ fortran: f951$(exeext) .PHONY: fortran gfortranspec.o: $(srcdir)/fortran/gfortranspec.c $(SYSTEM_H) $(TM_H) $(GCC_H) \ - $(CONFIG_H) coretypes.h intl.h + $(CONFIG_H) coretypes.h intl.h opts.h (SHLIB_LINK='$(SHLIB_LINK)'; \ $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) $(DRIVER_DEFINES) \ $(INCLUDES) $(srcdir)/fortran/gfortranspec.c) @@ -320,7 +320,7 @@ fortran.stagefeedback: stageprofile-start # TODO: Add dependencies on the backend/tree header files $(F95_PARSER_OBJS): fortran/gfortran.h fortran/libgfortran.h \ - fortran/intrinsic.h fortran/match.h \ + fortran/intrinsic.h fortran/match.h fortran/constructor.h \ fortran/parse.h fortran/arith.h fortran/target-memory.h \ $(CONFIG_H) $(SYSTEM_H) $(TM_H) $(TM_P_H) coretypes.h \ $(RTL_H) $(TREE_H) $(TREE_DUMP_H) $(GGC_H) $(EXPR_H) \ @@ -336,16 +336,17 @@ GFORTRAN_TRANS_DEPS = fortran/gfortran.h fortran/libgfortran.h \ fortran/f95-lang.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \ gt-fortran-f95-lang.h gtype-fortran.h $(CGRAPH_H) $(TARGET_H) fortran/cpp.h \ $(BUILTINS_DEF) fortran/types.def \ - libfuncs.h expr.h except.h + libfuncs.h expr.h fortran/scanner.o: toplev.h fortran/cpp.h fortran/convert.o: $(GFORTRAN_TRANS_DEPS) +fortran/frontend-passes.o: $(GFORTRAN_TRANS_DEPS) fortran/trans.o: $(GFORTRAN_TRANS_DEPS) tree-iterator.h fortran/trans-decl.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-decl.h \ $(CGRAPH_H) $(TARGET_H) $(FUNCTION_H) $(FLAGS_H) $(RTL_H) $(GIMPLE_H) \ $(TREE_DUMP_H) debug.h pointer-set.h fortran/trans-types.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-types.h \ $(REAL_H) toplev.h $(TARGET_H) $(FLAGS_H) dwarf2out.h -fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS) +fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS) realmpfr.h fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h fortran/trans-openmp.o: $(GFORTRAN_TRANS_DEPS) diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index 674b2462a49..2a9ea750103 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -1,5 +1,6 @@ /* Compiler arithmetic - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, + 2009, 2010 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -30,6 +31,7 @@ along with GCC; see the file COPYING3. If not see #include "gfortran.h" #include "arith.h" #include "target-memory.h" +#include "constructor.h" /* MPFR does not have a direct replacement for mpz_set_f() from GMP. It's easily implemented with a few calls though. */ @@ -258,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 (); } @@ -399,47 +403,6 @@ gfc_check_real_range (mpfr_t p, int kind) } -/* Function to return a constant expression node of a given type and kind. */ - -gfc_expr * -gfc_constant_result (bt type, int kind, locus *where) -{ - gfc_expr *result; - - if (!where) - gfc_internal_error ("gfc_constant_result(): locus 'where' cannot be NULL"); - - result = gfc_get_expr (); - - result->expr_type = EXPR_CONSTANT; - result->ts.type = type; - result->ts.kind = kind; - result->where = *where; - - switch (type) - { - case BT_INTEGER: - mpz_init (result->value.integer); - break; - - case BT_REAL: - gfc_set_model_kind (kind); - mpfr_init (result->value.real); - break; - - case BT_COMPLEX: - gfc_set_model_kind (kind); - mpc_init2 (result->value.complex, mpfr_get_default_prec()); - break; - - default: - break; - } - - return result; -} - - /* Low-level arithmetic functions. All of these subroutines assume that all operands are of the same type and return an operand of the same type. The other thing about these subroutines is that they @@ -451,7 +414,7 @@ gfc_arith_not (gfc_expr *op1, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, op1->ts.kind, &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where); result->value.logical = !op1->value.logical; *resultp = result; @@ -464,8 +427,8 @@ gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2), - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), + &op1->where); result->value.logical = op1->value.logical && op2->value.logical; *resultp = result; @@ -478,8 +441,8 @@ gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2), - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), + &op1->where); result->value.logical = op1->value.logical || op2->value.logical; *resultp = result; @@ -492,8 +455,8 @@ gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2), - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), + &op1->where); result->value.logical = op1->value.logical == op2->value.logical; *resultp = result; @@ -506,8 +469,8 @@ gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2), - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), + &op1->where); result->value.logical = op1->value.logical != op2->value.logical; *resultp = result; @@ -621,7 +584,7 @@ gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp) gfc_expr *result; arith rc; - result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); switch (op1->ts.type) { @@ -653,7 +616,7 @@ gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) gfc_expr *result; arith rc; - result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); switch (op1->ts.type) { @@ -687,7 +650,7 @@ gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) gfc_expr *result; arith rc; - result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); switch (op1->ts.type) { @@ -721,7 +684,7 @@ gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) gfc_expr *result; arith rc; - result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); switch (op1->ts.type) { @@ -758,7 +721,7 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) rc = ARITH_OK; - result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); switch (op1->ts.type) { @@ -823,10 +786,9 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) int power_sign; gfc_expr *result; arith rc; - extern bool init_flag; rc = ARITH_OK; - result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); switch (op2->ts.type) { @@ -938,7 +900,7 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) case BT_REAL: - if (init_flag) + if (gfc_init_expr_flag) { if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger " "exponent in an initialization " @@ -960,7 +922,7 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) case BT_COMPLEX: { - if (init_flag) + if (gfc_init_expr_flag) { if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger " "exponent in an initialization " @@ -992,8 +954,8 @@ gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) int len; gcc_assert (op1->ts.kind == op2->ts.kind); - result = gfc_constant_result (BT_CHARACTER, op1->ts.kind, - &op1->where); + result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind, + &op1->where); len = op1->value.character.length + op2->value.character.length; @@ -1162,8 +1124,8 @@ gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); result->value.logical = (op1->ts.type == BT_COMPLEX) ? compare_complex (op1, op2) : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0); @@ -1178,8 +1140,8 @@ gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); result->value.logical = (op1->ts.type == BT_COMPLEX) ? !compare_complex (op1, op2) : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0); @@ -1194,8 +1156,8 @@ gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0); *resultp = result; @@ -1208,8 +1170,8 @@ gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0); *resultp = result; @@ -1222,8 +1184,8 @@ gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0); *resultp = result; @@ -1236,8 +1198,8 @@ gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0); *resultp = result; @@ -1249,7 +1211,8 @@ static arith reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op, gfc_expr **result) { - gfc_constructor *c, *head; + gfc_constructor_base head; + gfc_constructor *c; gfc_expr *r; arith rc; @@ -1257,9 +1220,8 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op, return eval (op, result); rc = ARITH_OK; - head = gfc_copy_constructor (op->value.constructor); - - for (c = head; c; c = c->next) + head = gfc_constructor_copy (op->value.constructor); + for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) { rc = reduce_unary (eval, c->expr, &r); @@ -1270,18 +1232,15 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op, } if (rc != ARITH_OK) - gfc_free_constructor (head); + gfc_constructor_free (head); else { - r = gfc_get_expr (); - r->expr_type = EXPR_ARRAY; - r->value.constructor = head; + gfc_constructor *c = gfc_constructor_first (head); + r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, + &op->where); r->shape = gfc_copy_shape (op->shape, op->rank); - - r->ts = head->expr->ts; - r->where = op->where; r->rank = op->rank; - + r->value.constructor = head; *result = r; } @@ -1293,14 +1252,13 @@ static arith reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), gfc_expr *op1, gfc_expr *op2, gfc_expr **result) { - gfc_constructor *c, *head; + gfc_constructor_base head; + gfc_constructor *c; gfc_expr *r; - arith rc; + arith rc = ARITH_OK; - head = gfc_copy_constructor (op1->value.constructor); - rc = ARITH_OK; - - for (c = head; c; c = c->next) + head = gfc_constructor_copy (op1->value.constructor); + for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) { if (c->expr->expr_type == EXPR_CONSTANT) rc = eval (c->expr, op2, &r); @@ -1314,18 +1272,15 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), } if (rc != ARITH_OK) - gfc_free_constructor (head); + gfc_constructor_free (head); else { - r = gfc_get_expr (); - r->expr_type = EXPR_ARRAY; - r->value.constructor = head; + gfc_constructor *c = gfc_constructor_first (head); + r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, + &op1->where); r->shape = gfc_copy_shape (op1->shape, op1->rank); - - r->ts = head->expr->ts; - r->where = op1->where; r->rank = op1->rank; - + r->value.constructor = head; *result = r; } @@ -1337,14 +1292,13 @@ static arith reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), gfc_expr *op1, gfc_expr *op2, gfc_expr **result) { - gfc_constructor *c, *head; + gfc_constructor_base head; + gfc_constructor *c; gfc_expr *r; - arith rc; + arith rc = ARITH_OK; - head = gfc_copy_constructor (op2->value.constructor); - rc = ARITH_OK; - - for (c = head; c; c = c->next) + head = gfc_constructor_copy (op2->value.constructor); + for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) { if (c->expr->expr_type == EXPR_CONSTANT) rc = eval (op1, c->expr, &r); @@ -1358,18 +1312,15 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), } if (rc != ARITH_OK) - gfc_free_constructor (head); + gfc_constructor_free (head); else { - r = gfc_get_expr (); - r->expr_type = EXPR_ARRAY; - r->value.constructor = head; + gfc_constructor *c = gfc_constructor_first (head); + r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, + &op2->where); r->shape = gfc_copy_shape (op2->shape, op2->rank); - - r->ts = head->expr->ts; - r->where = op2->where; r->rank = op2->rank; - + r->value.constructor = head; *result = r; } @@ -1386,52 +1337,41 @@ static arith reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), gfc_expr *op1, gfc_expr *op2, gfc_expr **result) { - gfc_constructor *c, *d, *head; + gfc_constructor_base head; + gfc_constructor *c, *d; gfc_expr *r; - arith rc; + arith rc = ARITH_OK; - head = gfc_copy_constructor (op1->value.constructor); + if (gfc_check_conformance (op1, op2, + "elemental binary operation") != SUCCESS) + return ARITH_INCOMMENSURATE; - rc = ARITH_OK; - d = op2->value.constructor; - - if (gfc_check_conformance (op1, op2, "elemental binary operation") - != SUCCESS) - rc = ARITH_INCOMMENSURATE; - else + head = gfc_constructor_copy (op1->value.constructor); + for (c = gfc_constructor_first (head), + d = gfc_constructor_first (op2->value.constructor); + c && d; + c = gfc_constructor_next (c), d = gfc_constructor_next (d)) { - for (c = head; c; c = c->next, d = d->next) - { - if (d == NULL) - { - rc = ARITH_INCOMMENSURATE; - break; - } - - rc = reduce_binary (eval, c->expr, d->expr, &r); - if (rc != ARITH_OK) - break; - - gfc_replace_expr (c->expr, r); - } + rc = reduce_binary (eval, c->expr, d->expr, &r); + if (rc != ARITH_OK) + break; - if (d != NULL) - rc = ARITH_INCOMMENSURATE; + gfc_replace_expr (c->expr, r); } + if (c || d) + rc = ARITH_INCOMMENSURATE; + if (rc != ARITH_OK) - gfc_free_constructor (head); + gfc_constructor_free (head); else { - r = gfc_get_expr (); - r->expr_type = EXPR_ARRAY; - r->value.constructor = head; + gfc_constructor *c = gfc_constructor_first (head); + r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, + &op1->where); r->shape = gfc_copy_shape (op1->shape, op1->rank); - - r->ts = head->expr->ts; - r->where = op1->where; r->rank = op1->rank; - + r->value.constructor = head; *result = r; } @@ -1644,17 +1584,9 @@ eval_intrinsic (gfc_intrinsic_op op, runtime: /* Create a run-time expression. */ - result = gfc_get_expr (); + result = gfc_get_operator_expr (&op1->where, op, op1, op2); result->ts = temp.ts; - result->expr_type = EXPR_OP; - result->value.op.op = op; - - result->value.op.op1 = op1; - result->value.op.op2 = op2; - - result->where = op1->where; - return result; } @@ -1921,7 +1853,7 @@ gfc_convert_integer (const char *buffer, int kind, int radix, locus *where) gfc_expr *e; const char *t; - e = gfc_constant_result (BT_INTEGER, kind, where); + e = gfc_get_constant_expr (BT_INTEGER, kind, where); /* A leading plus is allowed, but not by mpz_set_str. */ if (buffer[0] == '+') t = buffer + 1; @@ -1940,7 +1872,7 @@ gfc_convert_real (const char *buffer, int kind, locus *where) { gfc_expr *e; - e = gfc_constant_result (BT_REAL, kind, where); + e = gfc_get_constant_expr (BT_REAL, kind, where); mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE); return e; @@ -1955,7 +1887,7 @@ gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind) { gfc_expr *e; - e = gfc_constant_result (BT_COMPLEX, kind, &real->where); + e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where); mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real, GFC_MPC_RND_MODE); @@ -2022,7 +1954,7 @@ gfc_int2int (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_INTEGER, kind, &src->where); + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); mpz_set (result->value.integer, src->value.integer); @@ -2052,7 +1984,7 @@ gfc_int2real (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_REAL, kind, &src->where); + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE); @@ -2075,7 +2007,7 @@ gfc_int2complex (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_COMPLEX, kind, &src->where); + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE); @@ -2099,7 +2031,7 @@ gfc_real2int (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_INTEGER, kind, &src->where); + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where); @@ -2122,7 +2054,7 @@ gfc_real2real (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_REAL, kind, &src->where); + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); mpfr_set (result->value.real, src->value.real, GFC_RND_MODE); @@ -2153,7 +2085,7 @@ gfc_real2complex (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_COMPLEX, kind, &src->where); + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE); @@ -2184,7 +2116,7 @@ gfc_complex2int (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_INTEGER, kind, &src->where); + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex), &src->where); @@ -2208,7 +2140,7 @@ gfc_complex2real (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_REAL, kind, &src->where); + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); mpc_real (result->value.real, src->value.complex, GFC_RND_MODE); @@ -2239,7 +2171,7 @@ gfc_complex2complex (gfc_expr *src, int kind) gfc_expr *result; arith rc; - result = gfc_constant_result (BT_COMPLEX, kind, &src->where); + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE); @@ -2284,7 +2216,7 @@ gfc_log2log (gfc_expr *src, int kind) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, kind, &src->where); + result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); result->value.logical = src->value.logical; return result; @@ -2298,7 +2230,7 @@ gfc_log2int (gfc_expr *src, int kind) { gfc_expr *result; - result = gfc_constant_result (BT_INTEGER, kind, &src->where); + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); mpz_set_si (result->value.integer, src->value.logical); return result; @@ -2312,7 +2244,7 @@ gfc_int2log (gfc_expr *src, int kind) { gfc_expr *result; - result = gfc_constant_result (BT_LOGICAL, kind, &src->where); + result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0); return result; @@ -2328,7 +2260,7 @@ hollerith2representation (gfc_expr *result, gfc_expr *src) { int src_len, result_len; - src_len = src->representation.length; + src_len = src->representation.length - src->ts.u.pad; result_len = gfc_target_expr_size (result); if (src_len > result_len) @@ -2355,12 +2287,7 @@ gfc_expr * gfc_hollerith2int (gfc_expr *src, int kind) { gfc_expr *result; - - result = gfc_get_expr (); - result->expr_type = EXPR_CONSTANT; - result->ts.type = BT_INTEGER; - result->ts.kind = kind; - result->where = src->where; + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); hollerith2representation (result, src); gfc_interpret_integer (kind, (unsigned char *) result->representation.string, @@ -2376,12 +2303,7 @@ gfc_expr * gfc_hollerith2real (gfc_expr *src, int kind) { gfc_expr *result; - - result = gfc_get_expr (); - result->expr_type = EXPR_CONSTANT; - result->ts.type = BT_REAL; - result->ts.kind = kind; - result->where = src->where; + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); hollerith2representation (result, src); gfc_interpret_float (kind, (unsigned char *) result->representation.string, @@ -2397,12 +2319,7 @@ gfc_expr * gfc_hollerith2complex (gfc_expr *src, int kind) { gfc_expr *result; - - result = gfc_get_expr (); - result->expr_type = EXPR_CONSTANT; - result->ts.type = BT_COMPLEX; - result->ts.kind = kind; - result->where = src->where; + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); hollerith2representation (result, src); gfc_interpret_complex (kind, (unsigned char *) result->representation.string, @@ -2437,12 +2354,7 @@ gfc_expr * gfc_hollerith2logical (gfc_expr *src, int kind) { gfc_expr *result; - - result = gfc_get_expr (); - result->expr_type = EXPR_CONSTANT; - result->ts.type = BT_LOGICAL; - result->ts.kind = kind; - result->where = src->where; + result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); hollerith2representation (result, src); gfc_interpret_logical (kind, (unsigned char *) result->representation.string, diff --git a/gcc/fortran/arith.h b/gcc/fortran/arith.h index 344bc78d481..9d79634aea0 100644 --- a/gcc/fortran/arith.h +++ b/gcc/fortran/arith.h @@ -22,8 +22,6 @@ along with GCC; see the file COPYING3. If not see #ifndef GFC_ARITH_H #define GFC_ARITH_H -#include "gfortran.h" - /* MPFR also does not have the conversion of a mpfr_t to a mpz_t, so declare a function for this as well. */ @@ -31,9 +29,6 @@ void gfc_mpfr_to_mpz (mpz_t, mpfr_t, locus *); void gfc_set_model_kind (int); void gfc_set_model (mpfr_t); -/* Return a constant result of a given type and kind, with locus. */ -gfc_expr *gfc_constant_result (bt, int, locus *); - /* Make sure a gfc_expr expression is within its allowed range. Checks for overflow and underflow. */ arith gfc_range_check (gfc_expr *); diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index e0714e3049a..a26be7891de 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -23,6 +23,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "gfortran.h" #include "match.h" +#include "constructor.h" /**************** Array reference matching subroutines *****************/ @@ -61,12 +62,13 @@ gfc_copy_array_ref (gfc_array_ref *src) expression. */ static match -match_subscript (gfc_array_ref *ar, int init) +match_subscript (gfc_array_ref *ar, int init, bool match_star) { - match m; + match m = MATCH_ERROR; + bool star = false; int i; - i = ar->dimen; + i = ar->dimen + ar->codimen; ar->c_where[i] = gfc_current_locus; ar->start[i] = ar->end[i] = ar->stride[i] = NULL; @@ -81,25 +83,38 @@ match_subscript (gfc_array_ref *ar, int init) goto end_element; /* Get start element. */ - if (init) + if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) + star = true; + + if (!star && init) m = gfc_match_init_expr (&ar->start[i]); - else + 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; if (gfc_match_char (':') == MATCH_NO) - return MATCH_YES; + goto matched; + + if (star) + { + gfc_error ("Unexpected '*' in coarray subscript at %C"); + return MATCH_ERROR; + } /* Get an optional end element. Because we've seen the colon, we definitely have a range along this dimension. */ end_element: ar->dimen_type[i] = DIMEN_RANGE; - if (init) + if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) + star = true; + else if (init) m = gfc_match_init_expr (&ar->end[i]); else m = gfc_match_expr (&ar->end[i]); @@ -110,6 +125,12 @@ end_element: /* See if we have an optional stride. */ if (gfc_match_char (':') == MATCH_YES) { + if (star) + { + gfc_error ("Strides not allowed in coarray subscript at %C"); + return MATCH_ERROR; + } + m = init ? gfc_match_init_expr (&ar->stride[i]) : gfc_match_expr (&ar->stride[i]); @@ -119,6 +140,10 @@ end_element: return MATCH_ERROR; } +matched: + if (star) + ar->dimen_type[i] = DIMEN_STAR; + return MATCH_YES; } @@ -128,14 +153,23 @@ end_element: to consist of init expressions. */ match -gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init) +gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, + int corank) { match m; + bool matched_bracket = false; memset (ar, '\0', sizeof (ar)); ar->where = gfc_current_locus; ar->as = as; + ar->type = AR_UNKNOWN; + + if (gfc_match_char ('[') == MATCH_YES) + { + matched_bracket = true; + goto coarray; + } if (gfc_match_char ('(') != MATCH_YES) { @@ -144,34 +178,89 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init) return MATCH_YES; } - ar->type = AR_UNKNOWN; - for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++) { - m = match_subscript (ar, init); + m = match_subscript (ar, init, false); if (m == MATCH_ERROR) - goto error; + return MATCH_ERROR; if (gfc_match_char (')') == MATCH_YES) - goto matched; + { + ar->dimen++; + goto coarray; + } if (gfc_match_char (',') != MATCH_YES) { gfc_error ("Invalid form of array reference at %C"); - goto error; + return MATCH_ERROR; } } gfc_error ("Array reference at %C cannot have more than %d dimensions", GFC_MAX_DIMENSIONS); - -error: return MATCH_ERROR; -matched: - ar->dimen++; +coarray: + if (!matched_bracket && gfc_match_char ('[') != MATCH_YES) + { + if (ar->dimen > 0) + return MATCH_YES; + else + return MATCH_ERROR; + } + + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return MATCH_ERROR; + } + + if (corank == 0) + { + gfc_error ("Unexpected coarray designator at %C"); + return MATCH_ERROR; + } + + for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++) + { + m = match_subscript (ar, init, ar->codimen == (corank - 1)); + if (m == MATCH_ERROR) + return MATCH_ERROR; + + 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) + { + 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; + } + } + + gfc_error ("Array reference at %C cannot have more than %d dimensions", + GFC_MAX_DIMENSIONS); + return MATCH_ERROR; - return MATCH_YES; } @@ -188,7 +277,7 @@ gfc_free_array_spec (gfc_array_spec *as) if (as == NULL) return; - for (i = 0; i < as->rank; i++) + for (i = 0; i < as->rank + as->corank; i++) { gfc_free_expr (as->lower[i]); gfc_free_expr (as->upper[i]); @@ -211,10 +300,14 @@ resolve_array_bound (gfc_expr *e, int check_constant) || gfc_specification_expr (e) == FAILURE) return FAILURE; - if (check_constant && gfc_is_constant_expr (e) == 0) + if (check_constant && !gfc_is_constant_expr (e)) { - gfc_error ("Variable '%s' at %L in this context must be constant", - e->symtree->n.sym->name, &e->where); + if (e->expr_type == EXPR_VARIABLE) + gfc_error ("Variable '%s' at %L in this context must be constant", + e->symtree->n.sym->name, &e->where); + else + gfc_error ("Expression at %L in this context must be constant", + &e->where); return FAILURE; } @@ -234,7 +327,7 @@ gfc_resolve_array_spec (gfc_array_spec *as, int check_constant) if (as == NULL) return SUCCESS; - for (i = 0; i < as->rank; i++) + for (i = 0; i < as->rank + as->corank; i++) { e = as->lower[i]; if (resolve_array_bound (e, check_constant) == FAILURE) @@ -290,12 +383,12 @@ match_array_element_spec (gfc_array_spec *as) gfc_expr **upper, **lower; match m; - lower = &as->lower[as->rank - 1]; - upper = &as->upper[as->rank - 1]; + lower = &as->lower[as->rank + as->corank - 1]; + upper = &as->upper[as->rank + as->corank - 1]; if (gfc_match_char ('*') == MATCH_YES) { - *lower = gfc_int_expr (1); + *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); return AS_ASSUMED_SIZE; } @@ -312,7 +405,7 @@ match_array_element_spec (gfc_array_spec *as) if (gfc_match_char (':') == MATCH_NO) { - *lower = gfc_int_expr (1); + *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); return AS_EXPLICIT; } @@ -335,22 +428,19 @@ match_array_element_spec (gfc_array_spec *as) /* Matches an array specification, incidentally figuring out what sort - it is. */ + it is. Match either a normal array specification, or a coarray spec + or both. Optionally allow [:] for coarrays. */ match -gfc_match_array_spec (gfc_array_spec **asp) +gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) { array_type current_type; gfc_array_spec *as; int i; - - if (gfc_match_char ('(') != MATCH_YES) - { - *asp = NULL; - return MATCH_NO; - } - + as = gfc_get_array_spec (); + as->corank = 0; + as->rank = 0; for (i = 0; i < GFC_MAX_DIMENSIONS; i++) { @@ -358,12 +448,27 @@ gfc_match_array_spec (gfc_array_spec **asp) as->upper[i] = NULL; } - as->rank = 1; + if (!match_dim) + goto coarray; + + if (gfc_match_char ('(') != MATCH_YES) + { + if (!match_codim) + goto done; + goto coarray; + } for (;;) { + as->rank++; current_type = match_array_element_spec (as); + /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size + and implied-shape specifications. If the rank is at least 2, we can + distinguish between them. But for rank 1, we currently return + ASSUMED_SIZE; this gets adjusted later when we know for sure + whether the symbol parsed is a PARAMETER or not. */ + if (as->rank == 1) { if (current_type == AS_UNKNOWN) @@ -376,6 +481,15 @@ gfc_match_array_spec (gfc_array_spec **asp) case AS_UNKNOWN: goto cleanup; + case AS_IMPLIED_SHAPE: + if (current_type != AS_ASSUMED_SHAPE) + { + gfc_error ("Bad array specification for implied-shape" + " array at %C"); + goto cleanup; + } + break; + case AS_EXPLICIT: if (current_type == AS_ASSUMED_SIZE) { @@ -414,6 +528,12 @@ gfc_match_array_spec (gfc_array_spec **asp) goto cleanup; case AS_ASSUMED_SIZE: + if (as->rank == 2 && current_type == AS_ASSUMED_SIZE) + { + as->type = AS_IMPLIED_SHAPE; + break; + } + gfc_error ("Bad specification for assumed size array at %C"); goto cleanup; } @@ -427,32 +547,145 @@ gfc_match_array_spec (gfc_array_spec **asp) goto cleanup; } - if (as->rank >= GFC_MAX_DIMENSIONS) + if (as->rank + as->corank >= GFC_MAX_DIMENSIONS) { gfc_error ("Array specification at %C has more than %d dimensions", GFC_MAX_DIMENSIONS); goto cleanup; } - if (as->rank >= 7 + if (as->corank + as->rank >= 7 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array " "specification at %C with more than 7 dimensions") == FAILURE) goto cleanup; + } - as->rank++; + if (!match_codim) + goto done; + +coarray: + if (gfc_match_char ('[') != MATCH_YES) + goto done; + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C") + == FAILURE) + goto cleanup; + + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + goto cleanup; + } + + for (;;) + { + as->corank++; + current_type = match_array_element_spec (as); + + if (current_type == AS_UNKNOWN) + goto cleanup; + + if (as->corank == 1) + as->cotype = current_type; + else + switch (as->cotype) + { /* See how current spec meshes with the existing. */ + case AS_IMPLIED_SHAPE: + case AS_UNKNOWN: + goto cleanup; + + case AS_EXPLICIT: + if (current_type == AS_ASSUMED_SIZE) + { + as->cotype = AS_ASSUMED_SIZE; + break; + } + + if (current_type == AS_EXPLICIT) + break; + + gfc_error ("Bad array specification for an explicitly " + "shaped array at %C"); + + goto cleanup; + + case AS_ASSUMED_SHAPE: + if ((current_type == AS_ASSUMED_SHAPE) + || (current_type == AS_DEFERRED)) + break; + + gfc_error ("Bad array specification for assumed shape " + "array at %C"); + goto cleanup; + + case AS_DEFERRED: + if (current_type == AS_DEFERRED) + break; + + if (current_type == AS_ASSUMED_SHAPE) + { + as->cotype = AS_ASSUMED_SHAPE; + break; + } + + gfc_error ("Bad specification for deferred shape array at %C"); + goto cleanup; + + case AS_ASSUMED_SIZE: + gfc_error ("Bad specification for assumed size array at %C"); + goto cleanup; + } + + if (gfc_match_char (']') == MATCH_YES) + break; + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected another dimension in array declaration at %C"); + goto cleanup; + } + + if (as->corank >= GFC_MAX_DIMENSIONS) + { + gfc_error ("Array specification at %C has more than %d " + "dimensions", GFC_MAX_DIMENSIONS); + goto cleanup; + } + } + + if (current_type == AS_EXPLICIT) + { + gfc_error ("Upper bound of last coarray dimension must be '*' at %C"); + goto cleanup; + } + + if (as->cotype == AS_ASSUMED_SIZE) + as->cotype = AS_EXPLICIT; + + if (as->rank == 0) + as->type = as->cotype; + +done: + if (as->rank == 0 && as->corank == 0) + { + *asp = NULL; + gfc_free_array_spec (as); + return MATCH_NO; } /* If a lower bounds of an assumed shape array is blank, put in one. */ if (as->type == AS_ASSUMED_SHAPE) { - for (i = 0; i < as->rank; i++) + for (i = 0; i < as->rank + as->corank; i++) { if (as->lower[i] == NULL) - as->lower[i] = gfc_int_expr (1); + as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); } } + *asp = as; + return MATCH_YES; cleanup: @@ -469,14 +702,64 @@ cleanup: gfc_try gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc) { + int i; + if (as == NULL) return SUCCESS; - if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE) + if (as->rank + && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE) + return FAILURE; + + if (as->corank + && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE) return FAILURE; - sym->as = as; + if (sym->as == NULL) + { + sym->as = as; + return SUCCESS; + } + + if (as->corank) + { + /* The "sym" has no corank (checked via gfc_add_codimension). Thus + the codimension is simply added. */ + gcc_assert (as->rank == 0 && sym->as->corank == 0); + + sym->as->cotype = as->cotype; + sym->as->corank = as->corank; + for (i = 0; i < as->corank; i++) + { + sym->as->lower[sym->as->rank + i] = as->lower[i]; + sym->as->upper[sym->as->rank + i] = as->upper[i]; + } + } + else + { + /* The "sym" has no rank (checked via gfc_add_dimension). Thus + the dimension is added - but first the codimensions (if existing + need to be shifted to make space for the dimension. */ + gcc_assert (as->corank == 0 && sym->as->rank == 0); + + sym->as->rank = as->rank; + sym->as->type = as->type; + sym->as->cray_pointee = as->cray_pointee; + sym->as->cp_was_assumed = as->cp_was_assumed; + for (i = 0; i < sym->as->corank; i++) + { + sym->as->lower[as->rank + i] = sym->as->lower[i]; + sym->as->upper[as->rank + i] = sym->as->upper[i]; + } + for (i = 0; i < as->rank; i++) + { + sym->as->lower[i] = as->lower[i]; + sym->as->upper[i] = as->upper[i]; + } + } + + gfc_free (as); return SUCCESS; } @@ -496,7 +779,7 @@ gfc_copy_array_spec (gfc_array_spec *src) *dest = *src; - for (i = 0; i < dest->rank; i++) + for (i = 0; i < dest->rank + dest->corank; i++) { dest->lower[i] = gfc_copy_expr (dest->lower[i]); dest->upper[i] = gfc_copy_expr (dest->upper[i]); @@ -543,6 +826,9 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) if (as1->rank != as2->rank) return 0; + if (as1->corank != as2->corank) + return 0; + if (as1->rank == 0) return 1; @@ -550,7 +836,7 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) return 0; if (as1->type == AS_EXPLICIT) - for (i = 0; i < as1->rank; i++) + for (i = 0; i < as1->rank + as1->corank; i++) { if (compare_bounds (as1->lower[i], as2->lower[i]) == 0) return 0; @@ -565,151 +851,6 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) /****************** Array constructor functions ******************/ -/* Start an array constructor. The constructor starts with zero - elements and should be appended to by gfc_append_constructor(). */ - -gfc_expr * -gfc_start_constructor (bt type, int kind, locus *where) -{ - gfc_expr *result; - - result = gfc_get_expr (); - - result->expr_type = EXPR_ARRAY; - result->rank = 1; - - result->ts.type = type; - result->ts.kind = kind; - result->where = *where; - return result; -} - - -/* Given an array constructor expression, append the new expression - node onto the constructor. */ - -void -gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr) -{ - gfc_constructor *c; - - if (base->value.constructor == NULL) - base->value.constructor = c = gfc_get_constructor (); - else - { - c = base->value.constructor; - while (c->next) - c = c->next; - - c->next = gfc_get_constructor (); - c = c->next; - } - - c->expr = new_expr; - - if (new_expr - && (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind)) - gfc_internal_error ("gfc_append_constructor(): New node has wrong kind"); -} - - -/* Given an array constructor expression, insert the new expression's - constructor onto the base's one according to the offset. */ - -void -gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1) -{ - gfc_constructor *c, *pre; - expr_t type; - int t; - - type = base->expr_type; - - if (base->value.constructor == NULL) - base->value.constructor = c1; - else - { - c = pre = base->value.constructor; - while (c) - { - if (type == EXPR_ARRAY) - { - t = mpz_cmp (c->n.offset, c1->n.offset); - if (t < 0) - { - pre = c; - c = c->next; - } - else if (t == 0) - { - gfc_error ("duplicated initializer"); - break; - } - else - break; - } - else - { - pre = c; - c = c->next; - } - } - - if (pre != c) - { - pre->next = c1; - c1->next = c; - } - else - { - c1->next = c; - base->value.constructor = c1; - } - } -} - - -/* Get a new constructor. */ - -gfc_constructor * -gfc_get_constructor (void) -{ - gfc_constructor *c; - - c = XCNEW (gfc_constructor); - c->expr = NULL; - c->iterator = NULL; - c->next = NULL; - mpz_init_set_si (c->n.offset, 0); - mpz_init_set_si (c->repeat, 0); - return c; -} - - -/* Free chains of gfc_constructor structures. */ - -void -gfc_free_constructor (gfc_constructor *p) -{ - gfc_constructor *next; - - if (p == NULL) - return; - - for (; p; p = next) - { - next = p->next; - - if (p->expr) - gfc_free_expr (p->expr); - if (p->iterator != NULL) - gfc_free_iterator (p->iterator, 1); - mpz_clear (p->n.offset); - mpz_clear (p->repeat); - gfc_free (p); - } -} - /* Given an expression node that might be an array constructor and a symbol, make sure that no iterators in this or child constructors @@ -717,11 +858,12 @@ gfc_free_constructor (gfc_constructor *p) duplicate was found. */ static int -check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master) +check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master) { + gfc_constructor *c; gfc_expr *e; - for (; c; c = c->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { e = c->expr; @@ -746,14 +888,15 @@ check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master) /* Forward declaration because these functions are mutually recursive. */ -static match match_array_cons_element (gfc_constructor **); +static match match_array_cons_element (gfc_constructor_base *); /* Match a list of array elements. */ static match -match_array_list (gfc_constructor **result) +match_array_list (gfc_constructor_base *result) { - gfc_constructor *p, *head, *tail, *new_cons; + gfc_constructor_base head; + gfc_constructor *p; gfc_iterator iter; locus old_loc; gfc_expr *e; @@ -772,8 +915,6 @@ match_array_list (gfc_constructor **result) if (m != MATCH_YES) goto cleanup; - tail = head; - if (gfc_match_char (',') != MATCH_YES) { m = MATCH_NO; @@ -788,7 +929,7 @@ match_array_list (gfc_constructor **result) if (m == MATCH_ERROR) goto cleanup; - m = match_array_cons_element (&new_cons); + m = match_array_cons_element (&head); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) @@ -799,9 +940,6 @@ match_array_list (gfc_constructor **result) goto cleanup; /* Could be a complex constant */ } - tail->next = new_cons; - tail = new_cons; - if (gfc_match_char (',') != MATCH_YES) { if (n > 2) @@ -820,19 +958,13 @@ match_array_list (gfc_constructor **result) goto cleanup; } - e = gfc_get_expr (); - e->expr_type = EXPR_ARRAY; - e->where = old_loc; + e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc); e->value.constructor = head; - p = gfc_get_constructor (); - p->where = gfc_current_locus; + p = gfc_constructor_append_expr (result, e, &gfc_current_locus); p->iterator = gfc_get_iterator (); *p->iterator = iter; - p->expr = e; - *result = p; - return MATCH_YES; syntax: @@ -840,7 +972,7 @@ syntax: m = MATCH_ERROR; cleanup: - gfc_free_constructor (head); + gfc_constructor_free (head); gfc_free_iterator (&iter, 0); gfc_current_locus = old_loc; return m; @@ -851,9 +983,8 @@ cleanup: single expression or a list of elements. */ static match -match_array_cons_element (gfc_constructor **result) +match_array_cons_element (gfc_constructor_base *result) { - gfc_constructor *p; gfc_expr *expr; match m; @@ -865,11 +996,7 @@ match_array_cons_element (gfc_constructor **result) if (m != MATCH_YES) return m; - p = gfc_get_constructor (); - p->where = gfc_current_locus; - p->expr = expr; - - *result = p; + gfc_constructor_append_expr (result, expr, &gfc_current_locus); return MATCH_YES; } @@ -879,7 +1006,7 @@ match_array_cons_element (gfc_constructor **result) match gfc_match_array_constructor (gfc_expr **result) { - gfc_constructor *head, *tail, *new_cons; + gfc_constructor_base head, new_cons; gfc_expr *expr; gfc_typespec ts; locus where; @@ -903,7 +1030,7 @@ gfc_match_array_constructor (gfc_expr **result) end_delim = " /)"; where = gfc_current_locus; - head = tail = NULL; + head = new_cons = NULL; seen_ts = false; /* Try to match an optional "type-spec ::" */ @@ -935,19 +1062,12 @@ gfc_match_array_constructor (gfc_expr **result) for (;;) { - m = match_array_cons_element (&new_cons); + m = match_array_cons_element (&head); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) goto syntax; - if (head == NULL) - head = new_cons; - else - tail->next = new_cons; - - tail = new_cons; - if (gfc_match_char (',') == MATCH_NO) break; } @@ -956,24 +1076,19 @@ gfc_match_array_constructor (gfc_expr **result) goto syntax; done: - expr = gfc_get_expr (); - - expr->expr_type = EXPR_ARRAY; - - expr->value.constructor = head; /* Size must be calculated at resolution time. */ - if (seen_ts) - expr->ts = ts; + { + expr = gfc_get_array_expr (ts.type, ts.kind, &where); + expr->ts = ts; + } else - expr->ts.type = BT_UNKNOWN; - + expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where); + + expr->value.constructor = head; if (expr->ts.u.cl) expr->ts.u.cl->length_from_typespec = seen_ts; - expr->where = where; - expr->rank = 1; - *result = expr; return MATCH_YES; @@ -981,7 +1096,7 @@ syntax: gfc_error ("Syntax error in array constructor at %C"); cleanup: - gfc_free_constructor (head); + gfc_constructor_free (head); return MATCH_ERROR; } @@ -1037,11 +1152,12 @@ check_element_type (gfc_expr *expr, bool convert) /* Recursive work function for gfc_check_constructor_type(). */ static gfc_try -check_constructor_type (gfc_constructor *c, bool convert) +check_constructor_type (gfc_constructor_base base, bool convert) { + gfc_constructor *c; gfc_expr *e; - for (; c; c = c->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { e = c->expr; @@ -1100,7 +1216,7 @@ cons_stack; static cons_stack *base; -static gfc_try check_constructor (gfc_constructor *, gfc_try (*) (gfc_expr *)); +static gfc_try check_constructor (gfc_constructor_base, gfc_try (*) (gfc_expr *)); /* Check an EXPR_VARIABLE expression in a constructor to make sure that that variable is an iteration variables. */ @@ -1113,7 +1229,7 @@ gfc_check_iter_variable (gfc_expr *expr) sym = expr->symtree->n.sym; - for (c = base; c; c = c->previous) + for (c = base; c && c->iterator; c = c->previous) if (sym == c->iterator->var->symtree->n.sym) return SUCCESS; @@ -1126,13 +1242,14 @@ gfc_check_iter_variable (gfc_expr *expr) constructor, giving variables with the names of iterators a pass. */ static gfc_try -check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *)) +check_constructor (gfc_constructor_base ctor, gfc_try (*check_function) (gfc_expr *)) { cons_stack element; gfc_expr *e; gfc_try t; + gfc_constructor *c; - for (; c; c = c->next) + for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c)) { e = c->expr; @@ -1186,14 +1303,13 @@ iterator_stack *iter_stack; typedef struct { - gfc_constructor *new_head, *new_tail; + gfc_constructor_base base; int extract_count, extract_n; gfc_expr *extracted; mpz_t *count; mpz_t *offset; gfc_component *component; - mpz_t *repeat; gfc_try (*expand_work_function) (gfc_expr *); } @@ -1201,7 +1317,7 @@ expand_info; static expand_info current_expand; -static gfc_try expand_constructor (gfc_constructor *); +static gfc_try expand_constructor (gfc_constructor_base); /* Work function that counts the number of elements present in a @@ -1260,21 +1376,10 @@ extract_element (gfc_expr *e) static gfc_try expand (gfc_expr *e) { - if (current_expand.new_head == NULL) - current_expand.new_head = current_expand.new_tail = - gfc_get_constructor (); - else - { - current_expand.new_tail->next = gfc_get_constructor (); - current_expand.new_tail = current_expand.new_tail->next; - } - - current_expand.new_tail->where = e->where; - current_expand.new_tail->expr = e; + gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base, + e, &e->where); - mpz_set (current_expand.new_tail->n.offset, *current_expand.offset); - current_expand.new_tail->n.component = current_expand.component; - mpz_set (current_expand.new_tail->repeat, *current_expand.repeat); + c->n.component = current_expand.component; return SUCCESS; } @@ -1294,7 +1399,7 @@ gfc_simplify_iterator_var (gfc_expr *e) if (p == NULL) return; /* Variable not found */ - gfc_replace_expr (e, gfc_int_expr (0)); + gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0)); mpz_set (e->value.integer, p->value); @@ -1408,11 +1513,12 @@ cleanup: passed expression. */ static gfc_try -expand_constructor (gfc_constructor *c) +expand_constructor (gfc_constructor_base base) { + gfc_constructor *c; gfc_expr *e; - for (; c; c = c->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c)) { if (c->iterator != NULL) { @@ -1437,9 +1543,8 @@ expand_constructor (gfc_constructor *c) gfc_free_expr (e); return FAILURE; } - current_expand.offset = &c->n.offset; + current_expand.offset = &c->offset; current_expand.component = c->n.component; - current_expand.repeat = &c->repeat; if (current_expand.expand_work_function (e) == FAILURE) return FAILURE; } @@ -1447,25 +1552,70 @@ expand_constructor (gfc_constructor *c) } +/* Given an array expression and an element number (starting at zero), + return a pointer to the array element. NULL is returned if the + size of the array has been exceeded. The expression node returned + remains a part of the array and should not be freed. Access is not + efficient at all, but this is another place where things do not + have to be particularly fast. */ + +static gfc_expr * +gfc_get_array_element (gfc_expr *array, int element) +{ + expand_info expand_save; + gfc_expr *e; + gfc_try rc; + + expand_save = current_expand; + current_expand.extract_n = element; + current_expand.expand_work_function = extract_element; + current_expand.extracted = NULL; + current_expand.extract_count = 0; + + iter_stack = NULL; + + rc = expand_constructor (array->value.constructor); + e = current_expand.extracted; + current_expand = expand_save; + + if (rc == FAILURE) + return NULL; + + return e; +} + + /* Top level subroutine for expanding constructors. We only expand 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; gfc_try rc; + /* If we can successfully get an array element at the max array size then + the array is too big to expand, so we just return. */ f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor); 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; } + /* We now know the array is not too big so go ahead and try to expand it. */ expand_save = current_expand; - current_expand.new_head = current_expand.new_tail = NULL; + current_expand.base = NULL; iter_stack = NULL; @@ -1473,13 +1623,13 @@ gfc_expand_constructor (gfc_expr *e) if (expand_constructor (e->value.constructor) == FAILURE) { - gfc_free_constructor (current_expand.new_head); + gfc_constructor_free (current_expand.base); rc = FAILURE; goto done; } - gfc_free_constructor (e->value.constructor); - e->value.constructor = current_expand.new_head; + gfc_constructor_free (e->value.constructor); + e->value.constructor = current_expand.base; rc = SUCCESS; @@ -1517,37 +1667,14 @@ gfc_constant_ac (gfc_expr *e) { expand_info expand_save; gfc_try rc; - gfc_constructor * con; - - rc = SUCCESS; - if (e->value.constructor - && e->value.constructor->expr->expr_type == EXPR_ARRAY) - { - /* Expand the constructor. */ - iter_stack = NULL; - expand_save = current_expand; - current_expand.expand_work_function = is_constant_element; + iter_stack = NULL; + expand_save = current_expand; + current_expand.expand_work_function = is_constant_element; - rc = expand_constructor (e->value.constructor); - - current_expand = expand_save; - } - else - { - /* No need to expand this further. */ - for (con = e->value.constructor; con; con = con->next) - { - if (con->expr->expr_type == EXPR_CONSTANT) - continue; - else - { - if (!gfc_is_constant_expr (con->expr)) - rc = FAILURE; - } - } - } + rc = expand_constructor (e->value.constructor); + current_expand = expand_save; if (rc == FAILURE) return 0; @@ -1561,11 +1688,12 @@ gfc_constant_ac (gfc_expr *e) int gfc_expanded_ac (gfc_expr *e) { - gfc_constructor *p; + gfc_constructor *c; if (e->expr_type == EXPR_ARRAY) - for (p = e->value.constructor; p; p = p->next) - if (p->iterator != NULL || !gfc_expanded_ac (p->expr)) + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + if (c->iterator != NULL || !gfc_expanded_ac (c->expr)) return 0; return 1; @@ -1578,19 +1706,20 @@ gfc_expanded_ac (gfc_expr *e) be of the same type. */ static gfc_try -resolve_array_list (gfc_constructor *p) +resolve_array_list (gfc_constructor_base base) { gfc_try t; + gfc_constructor *c; t = SUCCESS; - for (; p; p = p->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { - if (p->iterator != NULL - && gfc_resolve_iterator (p->iterator, false) == FAILURE) + if (c->iterator != NULL + && gfc_resolve_iterator (c->iterator, false) == FAILURE) t = FAILURE; - if (gfc_resolve_expr (p->expr) == FAILURE) + if (gfc_resolve_expr (c->expr) == FAILURE) t = FAILURE; } @@ -1613,7 +1742,8 @@ gfc_resolve_character_array_constructor (gfc_expr *expr) if (expr->ts.u.cl == NULL) { - for (p = expr->value.constructor; p; p = p->next) + for (p = gfc_constructor_first (expr->value.constructor); + p; p = gfc_constructor_next (p)) if (p->expr->ts.u.cl != NULL) { /* Ensure that if there is a char_len around that it is @@ -1634,7 +1764,8 @@ got_charlen: /* Check that all constant string elements have the same length until we reach the end or find a variable-length one. */ - for (p = expr->value.constructor; p; p = p->next) + for (p = gfc_constructor_first (expr->value.constructor); + p; p = gfc_constructor_next (p)) { int current_length = -1; gfc_ref *ref; @@ -1681,7 +1812,8 @@ got_charlen: gcc_assert (found_length != -1); /* Update the character length of the array constructor. */ - expr->ts.u.cl->length = gfc_int_expr (found_length); + expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + NULL, found_length); } else { @@ -1699,7 +1831,8 @@ got_charlen: (without typespec) all elements are verified to have the same length anyway. */ if (found_length != -1) - for (p = expr->value.constructor; p; p = p->next) + for (p = gfc_constructor_first (expr->value.constructor); + p; p = gfc_constructor_next (p)) if (p->expr->expr_type == EXPR_CONSTANT) { gfc_expr *cl = NULL; @@ -1718,7 +1851,7 @@ got_charlen: has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec); if (! cl - || (current_length != -1 && current_length < found_length)) + || (current_length != -1 && current_length != found_length)) gfc_set_constant_character_len (found_length, p->expr, has_ts ? -1 : found_length); } @@ -1749,8 +1882,8 @@ gfc_resolve_array_constructor (gfc_expr *expr) /* Copy an iterator structure. */ -static gfc_iterator * -copy_iterator (gfc_iterator *src) +gfc_iterator * +gfc_copy_iterator (gfc_iterator *src) { gfc_iterator *dest; @@ -1768,73 +1901,6 @@ copy_iterator (gfc_iterator *src) } -/* Copy a constructor structure. */ - -gfc_constructor * -gfc_copy_constructor (gfc_constructor *src) -{ - gfc_constructor *dest; - gfc_constructor *tail; - - if (src == NULL) - return NULL; - - dest = tail = NULL; - while (src) - { - if (dest == NULL) - dest = tail = gfc_get_constructor (); - else - { - tail->next = gfc_get_constructor (); - tail = tail->next; - } - tail->where = src->where; - tail->expr = gfc_copy_expr (src->expr); - tail->iterator = copy_iterator (src->iterator); - mpz_set (tail->n.offset, src->n.offset); - tail->n.component = src->n.component; - mpz_set (tail->repeat, src->repeat); - src = src->next; - } - - return dest; -} - - -/* Given an array expression and an element number (starting at zero), - return a pointer to the array element. NULL is returned if the - size of the array has been exceeded. The expression node returned - remains a part of the array and should not be freed. Access is not - efficient at all, but this is another place where things do not - have to be particularly fast. */ - -gfc_expr * -gfc_get_array_element (gfc_expr *array, int element) -{ - expand_info expand_save; - gfc_expr *e; - gfc_try rc; - - expand_save = current_expand; - current_expand.extract_n = element; - current_expand.expand_work_function = extract_element; - current_expand.extracted = NULL; - current_expand.extract_count = 0; - - iter_stack = NULL; - - rc = expand_constructor (array->value.constructor); - e = current_expand.extracted; - current_expand = expand_save; - - if (rc == FAILURE) - return NULL; - - return e; -} - - /********* Subroutines for determining the size of an array *********/ /* These are needed just to accommodate RESHAPE(). There are no @@ -1896,10 +1962,11 @@ spec_size (gfc_array_spec *as, mpz_t *result) } -/* Get the number of elements in an array section. */ +/* Get the number of elements in an array section. Optionally, also supply + the end value. */ gfc_try -gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result) +gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end) { mpz_t upper, lower, stride; gfc_try t; @@ -1972,6 +2039,15 @@ gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result) mpz_set_ui (*result, 0); t = SUCCESS; + if (end) + { + mpz_init (*end); + + mpz_sub_ui (*end, *result, 1UL); + mpz_mul (*end, *end, stride); + mpz_add (*end, *end, lower); + } + cleanup: mpz_clear (upper); mpz_clear (lower); @@ -1996,7 +2072,7 @@ ref_size (gfc_array_ref *ar, mpz_t *result) for (d = 0; d < ar->dimen; d++) { - if (gfc_ref_dimen_size (ar, d, &size) == FAILURE) + if (gfc_ref_dimen_size (ar, d, &size, NULL) == FAILURE) { mpz_clear (*result); return FAILURE; @@ -2042,7 +2118,7 @@ gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result) if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) dimen--; - return gfc_ref_dimen_size (&ref->u.ar, i - 1, result); + return gfc_ref_dimen_size (&ref->u.ar, i - 1, result, NULL); } } @@ -2178,7 +2254,7 @@ gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape) { if (ar->dimen_type[i] != DIMEN_ELEMENT) { - if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE) + if (gfc_ref_dimen_size (ar, i, &shape[d], NULL) == FAILURE) goto cleanup; d++; } @@ -2208,7 +2284,8 @@ gfc_find_array_ref (gfc_expr *e) for (ref = e->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY - && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION)) + && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION + || (ref->u.ar.type == AR_ELEMENT && ref->u.ar.dimen == 0))) break; if (ref == NULL) diff --git a/gcc/fortran/bbt.c b/gcc/fortran/bbt.c index fa60e4fee22..1e7d8c07f84 100644 --- a/gcc/fortran/bbt.c +++ b/gcc/fortran/bbt.c @@ -37,6 +37,7 @@ along with GCC; see the file COPYING3. If not see July 1997 Doctor Dobb's Journal, "Treaps in Java". */ #include "config.h" +#include "system.h" #include "gfortran.h" typedef struct gfc_treap diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 9b6f8ea0a4f..51ea8778fe3 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1,5 +1,5 @@ /* Check functions - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Andy Vaught & Katherine Holcomb @@ -31,6 +31,7 @@ along with GCC; see the file COPYING3. If not see #include "flags.h" #include "gfortran.h" #include "intrinsic.h" +#include "constructor.h" /* Make sure an expression is a scalar. */ @@ -42,7 +43,8 @@ scalar_check (gfc_expr *e, int n) return SUCCESS; gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where); + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where); return FAILURE; } @@ -57,8 +59,8 @@ type_check (gfc_expr *e, int n, bt type) return SUCCESS; gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where, - gfc_basic_typename (type)); + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where, gfc_basic_typename (type)); return FAILURE; } @@ -85,7 +87,8 @@ numeric_check (gfc_expr *e, int n) } gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where); + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where); return FAILURE; } @@ -99,7 +102,7 @@ int_or_real_check (gfc_expr *e, int n) if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " - "or REAL", gfc_current_intrinsic_arg[n], + "or REAL", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return FAILURE; } @@ -116,7 +119,24 @@ real_or_complex_check (gfc_expr *e, int n) if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL " - "or COMPLEX", gfc_current_intrinsic_arg[n], + "or COMPLEX", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + return FAILURE; + } + + return SUCCESS; +} + + +/* Check that an expression is INTEGER or PROCEDURE. */ + +static gfc_try +int_or_proc_check (gfc_expr *e, int n) +{ + if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " + "or PROCEDURE", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return FAILURE; } @@ -145,7 +165,7 @@ kind_check (gfc_expr *k, int n, bt type) if (k->expr_type != EXPR_CONSTANT) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &k->where); return FAILURE; } @@ -173,7 +193,7 @@ double_check (gfc_expr *d, int n) if (d->ts.kind != gfc_default_double_kind) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be double " - "precision", gfc_current_intrinsic_arg[n], + "precision", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &d->where); return FAILURE; } @@ -182,6 +202,47 @@ double_check (gfc_expr *d, int n) } +/* Check whether an expression is a coarray (without array designator). */ + +static bool +is_coarray (gfc_expr *e) +{ + bool coarray = false; + gfc_ref *ref; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + coarray = e->symtree->n.sym->attr.codimension; + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT) + coarray = ref->u.c.component->attr.codimension; + else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0 + || ref->u.ar.codimen != 0) + coarray = false; + } + + return coarray; +} + + +static gfc_try +coarray_check (gfc_expr *e, int n) +{ + if (!is_coarray (e)) + { + gfc_error ("Expected coarray variable as '%s' argument to the %s " + "intrinsic at %L", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + return FAILURE; + } + + return SUCCESS; +} + + /* Make sure the expression is a logical array. */ static gfc_try @@ -190,8 +251,8 @@ logical_array_check (gfc_expr *array, int n) if (array->ts.type != BT_LOGICAL || array->rank == 0) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical " - "array", gfc_current_intrinsic_arg[n], gfc_current_intrinsic, - &array->where); + "array", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &array->where); return FAILURE; } @@ -208,12 +269,125 @@ array_check (gfc_expr *e, int n) return SUCCESS; gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where); + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where); return FAILURE; } +/* If expr is a constant, then check to ensure that it is greater than + of equal to zero. */ + +static gfc_try +nonnegative_check (const char *arg, gfc_expr *expr) +{ + int i; + + if (expr->expr_type == EXPR_CONSTANT) + { + gfc_extract_int (expr, &i); + if (i < 0) + { + gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where); + return FAILURE; + } + } + + return SUCCESS; +} + + +/* If expr2 is constant, then check that the value is less than + (less than or equal to, if 'or_equal' is true) bit_size(expr1). */ + +static gfc_try +less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, + gfc_expr *expr2, bool or_equal) +{ + int i2, i3; + + if (expr2->expr_type == EXPR_CONSTANT) + { + gfc_extract_int (expr2, &i2); + i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); + if (or_equal) + { + if (i2 > gfc_integer_kinds[i3].bit_size) + { + gfc_error ("'%s' at %L must be less than " + "or equal to BIT_SIZE('%s')", + arg2, &expr2->where, arg1); + return FAILURE; + } + } + else + { + if (i2 >= gfc_integer_kinds[i3].bit_size) + { + gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')", + arg2, &expr2->where, arg1); + return FAILURE; + } + } + } + + return SUCCESS; +} + + +/* If expr is constant, then check that the value is less than or equal + to the bit_size of the kind k. */ + +static gfc_try +less_than_bitsizekind (const char *arg, gfc_expr *expr, int k) +{ + int i, val; + + if (expr->expr_type != EXPR_CONSTANT) + return SUCCESS; + + i = gfc_validate_kind (BT_INTEGER, k, false); + gfc_extract_int (expr, &val); + + if (val > gfc_integer_kinds[i].bit_size) + { + gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of " + "INTEGER(KIND=%d)", arg, &expr->where, k); + return FAILURE; + } + + return SUCCESS; +} + + +/* If expr2 and expr3 are constants, then check that the value is less than + or equal to bit_size(expr1). */ + +static gfc_try +less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2, + gfc_expr *expr2, const char *arg3, gfc_expr *expr3) +{ + int i2, i3; + + if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT) + { + gfc_extract_int (expr2, &i2); + gfc_extract_int (expr3, &i3); + i2 += i3; + i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); + if (i2 > gfc_integer_kinds[i3].bit_size) + { + gfc_error ("'%s + %s' at %L must be less than or equal " + "to BIT_SIZE('%s')", + arg2, arg3, &expr2->where, arg1); + return FAILURE; + } + } + + return SUCCESS; +} + /* Make sure two expressions have the same type. */ static gfc_try @@ -223,8 +397,9 @@ same_type_check (gfc_expr *e, int n, gfc_expr *f, int m) return SUCCESS; gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type " - "and kind as '%s'", gfc_current_intrinsic_arg[m], - gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]); + "and kind as '%s'", gfc_current_intrinsic_arg[m]->name, + gfc_current_intrinsic, &f->where, + gfc_current_intrinsic_arg[n]->name); return FAILURE; } @@ -239,7 +414,7 @@ rank_check (gfc_expr *e, int n, int rank) return SUCCESS; gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where, rank); return FAILURE; @@ -254,7 +429,7 @@ nonoptional_check (gfc_expr *e, int n) if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) { gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); } @@ -264,6 +439,26 @@ nonoptional_check (gfc_expr *e, int n) } +/* Check for ALLOCATABLE attribute. */ + +static gfc_try +allocatable_check (gfc_expr *e, int n) +{ + symbol_attribute attr; + + attr = gfc_variable_attr (e, NULL); + if (!attr.allocatable) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where); + return FAILURE; + } + + return SUCCESS; +} + + /* Check that an expression has a particular kind. */ static gfc_try @@ -273,7 +468,7 @@ kind_value_check (gfc_expr *e, int n, int k) return SUCCESS; gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where, k); return FAILURE; @@ -285,23 +480,25 @@ kind_value_check (gfc_expr *e, int n, int k) static gfc_try variable_check (gfc_expr *e, int n) { - if ((e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.flavor != FL_PARAMETER) - || (e->expr_type == EXPR_FUNCTION - && e->symtree->n.sym->result == e->symtree->n.sym)) - return SUCCESS; - if (e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.intent == INTENT_IN) + && e->symtree->n.sym->attr.intent == INTENT_IN + && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT + || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT)) { gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return FAILURE; } + if ((e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.flavor != FL_PARAMETER) + || (e->expr_type == EXPR_FUNCTION + && e->symtree->n.sym->result == e->symtree->n.sym)) + return SUCCESS; + gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable", - gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where); + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return FAILURE; } @@ -328,6 +525,36 @@ dim_check (gfc_expr *dim, int n, bool optional) } +/* If a coarray DIM parameter is a constant, make sure that it is greater than + zero and less than or equal to the corank of the given array. */ + +static gfc_try +dim_corank_check (gfc_expr *dim, gfc_expr *array) +{ + gfc_array_ref *ar; + int corank; + + gcc_assert (array->expr_type == EXPR_VARIABLE); + + if (dim->expr_type != EXPR_CONSTANT) + return SUCCESS; + + ar = gfc_find_array_ref (array); + corank = ar->as->corank; + + if (mpz_cmp_ui (dim->value.integer, 1) < 0 + || mpz_cmp_ui (dim->value.integer, corank) > 0) + { + gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid " + "codimension index", gfc_current_intrinsic, &dim->where); + + return FAILURE; + } + + return SUCCESS; +} + + /* If a DIM parameter is a constant, make sure that it is greater than zero and less than or equal to the rank of the given array. If allow_assumed is zero then dim must be less than the rank of the array @@ -342,12 +569,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); @@ -532,20 +762,11 @@ gfc_check_all_any (gfc_expr *mask, gfc_expr *dim) gfc_try gfc_check_allocated (gfc_expr *array) { - symbol_attribute attr; - if (variable_check (array, 0) == FAILURE) return FAILURE; - - attr = gfc_variable_attr (array, NULL); - if (!attr.allocatable) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", - gfc_current_intrinsic_arg[0], gfc_current_intrinsic, - &array->where); - return FAILURE; - } - + if (allocatable_check (array, 0) == FAILURE) + return FAILURE; + return SUCCESS; } @@ -562,8 +783,8 @@ gfc_check_a_p (gfc_expr *a, gfc_expr *p) if (a->ts.type != p->ts.type) { gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must " - "have the same type", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + "have the same type", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &p->where); return FAILURE; } @@ -609,7 +830,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) if (!attr1.pointer && !attr1.proc_pointer) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER", - gfc_current_intrinsic_arg[0], gfc_current_intrinsic, + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &pointer->where); return FAILURE; } @@ -627,15 +848,16 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) else { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer " - "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &target->where); + "or target VARIABLE or FUNCTION", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &target->where); return FAILURE; } if (attr1.pointer && !attr2.pointer && !attr2.target) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER " - "or a TARGET", gfc_current_intrinsic_arg[1], + "or a TARGET", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &target->where); return FAILURE; } @@ -700,6 +922,14 @@ gfc_check_besn (gfc_expr *n, gfc_expr *x) { if (type_check (n, 0, BT_INTEGER) == FAILURE) return FAILURE; + if (n->expr_type == EXPR_CONSTANT) + { + int i; + gfc_extract_int (n, &i); + if (i < 0 && gfc_notify_std (GFC_STD_GNU, "Extension: Negative argument " + "N at %L", &n->where) == FAILURE) + return FAILURE; + } if (type_check (x, 1, BT_REAL) == FAILURE) return FAILURE; @@ -708,14 +938,62 @@ gfc_check_besn (gfc_expr *n, gfc_expr *x) } +/* Transformational version of the Bessel JN and YN functions. */ + +gfc_try +gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x) +{ + if (type_check (n1, 0, BT_INTEGER) == FAILURE) + return FAILURE; + if (scalar_check (n1, 0) == FAILURE) + return FAILURE; + if (nonnegative_check("N1", n1) == FAILURE) + return FAILURE; + + if (type_check (n2, 1, BT_INTEGER) == FAILURE) + return FAILURE; + if (scalar_check (n2, 1) == FAILURE) + return FAILURE; + if (nonnegative_check("N2", n2) == FAILURE) + return FAILURE; + + if (type_check (x, 2, BT_REAL) == FAILURE) + return FAILURE; + if (scalar_check (x, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +gfc_try +gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j) +{ + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (j, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + gfc_try -gfc_check_btest (gfc_expr *i, gfc_expr *pos) +gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos) { if (type_check (i, 0, BT_INTEGER) == FAILURE) return FAILURE; + if (type_check (pos, 1, BT_INTEGER) == FAILURE) return FAILURE; + if (nonnegative_check ("pos", pos) == FAILURE) + return FAILURE; + + if (less_than_bitsize1 ("i", i, "pos", pos, false) == FAILURE) + return FAILURE; + return SUCCESS; } @@ -821,16 +1099,18 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) if (x->ts.type == BT_COMPLEX) { gfc_error ("'%s' argument of '%s' intrinsic at %L must not be " - "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &y->where); + "present if 'x' is COMPLEX", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &y->where); return FAILURE; } if (y->ts.type == BT_COMPLEX) { gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type " - "of either REAL or INTEGER", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &y->where); + "of either REAL or INTEGER", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &y->where); return FAILURE; } @@ -846,23 +1126,13 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) gfc_try gfc_check_complex (gfc_expr *x, gfc_expr *y) { - if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " - "or REAL", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic, &x->where); - return FAILURE; - } + if (int_or_real_check (x, 0) == FAILURE) + return FAILURE; if (scalar_check (x, 0) == FAILURE) return FAILURE; - if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " - "or REAL", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &y->where); - return FAILURE; - } + if (int_or_real_check (y, 1) == FAILURE) + return FAILURE; if (scalar_check (y, 1) == FAILURE) return FAILURE; @@ -930,7 +1200,7 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) { gfc_error ("'%s' argument of '%s' intrinsic at %L has " "invalid shape in dimension %d (%ld/%ld)", - gfc_current_intrinsic_arg[1], + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, i + 1, mpz_get_si (array->shape[i]), mpz_get_si (shift->shape[j])); @@ -944,7 +1214,7 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) else { gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank " - "%d or be a scalar", gfc_current_intrinsic_arg[1], + "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, array->rank - 1); return FAILURE; } @@ -988,16 +1258,18 @@ gfc_check_dcmplx (gfc_expr *x, gfc_expr *y) if (x->ts.type == BT_COMPLEX) { gfc_error ("'%s' argument of '%s' intrinsic at %L must not be " - "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &y->where); + "present if 'x' is COMPLEX", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &y->where); return FAILURE; } if (y->ts.type == BT_COMPLEX) { gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type " - "of either REAL or INTEGER", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &y->where); + "of either REAL or INTEGER", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &y->where); return FAILURE; } } @@ -1045,7 +1317,7 @@ gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) default: gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " - "or LOGICAL", gfc_current_intrinsic_arg[0], + "or LOGICAL", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &vector_a->where); return FAILURE; } @@ -1059,8 +1331,8 @@ gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) if (! identical_dimen_shape (vector_a, 0, vector_b, 0)) { gfc_error ("Different shape for arguments '%s' and '%s' at %L for " - "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[1], &vector_a->where); + "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, &vector_a->where); return FAILURE; } @@ -1078,7 +1350,7 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y) if (x->ts.kind != gfc_default_real_kind) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be default " - "real", gfc_current_intrinsic_arg[0], + "real", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &x->where); return FAILURE; } @@ -1086,7 +1358,7 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y) if (y->ts.kind != gfc_default_real_kind) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be default " - "real", gfc_current_intrinsic_arg[1], + "real", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); return FAILURE; } @@ -1096,6 +1368,31 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y) gfc_try +gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift) +{ + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (j, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (same_type_check (i, 0, j, 1) == FAILURE) + return FAILURE; + + if (type_check (shift, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + if (nonnegative_check ("SHIFT", shift) == FAILURE) + return FAILURE; + + if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +gfc_try gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, gfc_expr *dim) { @@ -1136,7 +1433,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, { gfc_error ("'%s' argument of '%s' intrinsic at %L has " "invalid shape in dimension %d (%ld/%ld)", - gfc_current_intrinsic_arg[1], + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, i + 1, mpz_get_si (array->shape[i]), mpz_get_si (shift->shape[j])); @@ -1150,7 +1447,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, else { gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank " - "%d or be a scalar", gfc_current_intrinsic_arg[1], + "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, array->rank - 1); return FAILURE; } @@ -1170,16 +1467,17 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, if (gfc_check_conformance (shift, boundary, "arguments '%s' and '%s' for " "intrinsic %s", - gfc_current_intrinsic_arg[1], - gfc_current_intrinsic_arg[2], + gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic ) == FAILURE) return FAILURE; } else { gfc_error ("'%s' argument of intrinsic '%s' at %L of must have " - "rank %d or be a scalar", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &shift->where, array->rank - 1); + "rank %d or be a scalar", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &shift->where, array->rank - 1); return FAILURE; } } @@ -1187,6 +1485,20 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, return SUCCESS; } +gfc_try +gfc_check_float (gfc_expr *a) +{ + if (type_check (a, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if ((a->ts.kind != gfc_default_integer_kind) + && gfc_notify_std (GFC_STD_GNU, "GNU extension: non-default INTEGER" + "kind argument to %s intrinsic at %L", + gfc_current_intrinsic, &a->where) == FAILURE ) + return FAILURE; + + return SUCCESS; +} /* A single complex argument. */ @@ -1199,7 +1511,6 @@ gfc_check_fn_c (gfc_expr *a) return SUCCESS; } - /* A single real argument. */ gfc_try @@ -1243,8 +1554,8 @@ gfc_check_fn_rc2008 (gfc_expr *a) if (a->ts.type == BT_COMPLEX && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: COMPLEX argument '%s' " "argument of '%s' intrinsic at %L", - gfc_current_intrinsic_arg[0], gfc_current_intrinsic, - &a->where) == FAILURE) + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &a->where) == FAILURE) return FAILURE; return SUCCESS; @@ -1319,19 +1630,6 @@ gfc_check_iand (gfc_expr *i, gfc_expr *j) gfc_try -gfc_check_ibclr (gfc_expr *i, gfc_expr *pos) -{ - if (type_check (i, 0, BT_INTEGER) == FAILURE) - return FAILURE; - - if (type_check (pos, 1, BT_INTEGER) == FAILURE) - return FAILURE; - - return SUCCESS; -} - - -gfc_try gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len) { if (type_check (i, 0, BT_INTEGER) == FAILURE) @@ -1343,17 +1641,13 @@ gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len) if (type_check (len, 2, BT_INTEGER) == FAILURE) return FAILURE; - return SUCCESS; -} - + if (nonnegative_check ("pos", pos) == FAILURE) + return FAILURE; -gfc_try -gfc_check_ibset (gfc_expr *i, gfc_expr *pos) -{ - if (type_check (i, 0, BT_INTEGER) == FAILURE) + if (nonnegative_check ("len", len) == FAILURE) return FAILURE; - if (type_check (pos, 1, BT_INTEGER) == FAILURE) + if (less_than_bitsize2 ("i", i, "pos", pos, "len", len) == FAILURE) return FAILURE; return SUCCESS; @@ -1482,9 +1776,9 @@ gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back, if (string->ts.kind != substring->ts.kind) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same " - "kind as '%s'", gfc_current_intrinsic_arg[1], + "kind as '%s'", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &substring->where, - gfc_current_intrinsic_arg[0]); + gfc_current_intrinsic_arg[0]->name); return FAILURE; } @@ -1607,7 +1901,7 @@ gfc_check_kind (gfc_expr *x) if (x->ts.type == BT_DERIVED) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a " - "non-derived type", gfc_current_intrinsic_arg[0], + "non-derived type", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &x->where); return FAILURE; } @@ -1640,6 +1934,34 @@ gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) gfc_try +gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) +{ + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return FAILURE; + } + + if (coarray_check (coarray, 0) == FAILURE) + return FAILURE; + + if (dim != NULL) + { + if (dim_check (dim, 1, false) == FAILURE) + return FAILURE; + + if (dim_corank_check (dim, coarray) == FAILURE) + return FAILURE; + } + + if (kind_check (kind, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +gfc_try gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind) { if (type_check (s, 0, BT_CHARACTER) == FAILURE) @@ -1907,7 +2229,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts)) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " - "or LOGICAL", gfc_current_intrinsic_arg[0], + "or LOGICAL", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &matrix_a->where); return FAILURE; } @@ -1915,7 +2237,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts)) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " - "or LOGICAL", gfc_current_intrinsic_arg[1], + "or LOGICAL", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &matrix_b->where); return FAILURE; } @@ -1939,8 +2261,8 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) { gfc_error ("Different shape on dimension 1 for arguments '%s' " "and '%s' at %L for intrinsic matmul", - gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[1], &matrix_a->where); + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, &matrix_a->where); return FAILURE; } break; @@ -1958,15 +2280,15 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) { gfc_error ("Different shape on dimension 2 for argument '%s' and " "dimension 1 for argument '%s' at %L for intrinsic " - "matmul", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[1], &matrix_a->where); + "matmul", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, &matrix_a->where); return FAILURE; } break; default: gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank " - "1 or 2", gfc_current_intrinsic_arg[0], + "1 or 2", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &matrix_a->where); return FAILURE; } @@ -2022,8 +2344,8 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap) if (m != NULL && gfc_check_conformance (a, m, "arguments '%s' and '%s' for intrinsic %s", - gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[2], + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic ) == FAILURE) return FAILURE; @@ -2076,8 +2398,8 @@ check_reduction (gfc_actual_arglist *ap) if (m != NULL && gfc_check_conformance (a, m, "arguments '%s' and '%s' for intrinsic %s", - gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[2], + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic) == FAILURE) return FAILURE; @@ -2107,6 +2429,52 @@ gfc_check_product_sum (gfc_actual_arglist *ap) } +/* For IANY, IALL and IPARITY. */ + +gfc_try +gfc_check_mask (gfc_expr *i, gfc_expr *kind) +{ + int k; + + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (nonnegative_check ("I", i) == FAILURE) + return FAILURE; + + if (kind_check (kind, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (kind) + gfc_extract_int (kind, &k); + else + k = gfc_default_integer_kind; + + if (less_than_bitsizekind ("I", i, k) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +gfc_try +gfc_check_transf_bit_intrins (gfc_actual_arglist *ap) +{ + if (ap->expr->ts.type != BT_INTEGER) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &ap->expr->where); + return FAILURE; + } + + if (array_check (ap->expr, 0) == FAILURE) + return FAILURE; + + return check_reduction (ap); +} + + gfc_try gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) { @@ -2124,33 +2492,39 @@ gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) gfc_try -gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) +gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask) { - symbol_attribute attr; + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; - if (variable_check (from, 0) == FAILURE) + if (type_check (j, 1, BT_INTEGER) == FAILURE) return FAILURE; - attr = gfc_variable_attr (from, NULL); - if (!attr.allocatable) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", - gfc_current_intrinsic_arg[0], gfc_current_intrinsic, - &from->where); - return FAILURE; - } + if (type_check (mask, 2, BT_INTEGER) == FAILURE) + return FAILURE; - if (variable_check (to, 0) == FAILURE) + if (same_type_check (i, 0, j, 1) == FAILURE) return FAILURE; - attr = gfc_variable_attr (to, NULL); - if (!attr.allocatable) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", - gfc_current_intrinsic_arg[0], gfc_current_intrinsic, - &to->where); - return FAILURE; - } + if (same_type_check (i, 0, mask, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +gfc_try +gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) +{ + if (variable_check (from, 0) == FAILURE) + return FAILURE; + if (allocatable_check (from, 0) == FAILURE) + return FAILURE; + + if (variable_check (to, 1) == FAILURE) + return FAILURE; + if (allocatable_check (to, 1) == FAILURE) + return FAILURE; if (same_type_check (to, 1, from, 0) == FAILURE) return FAILURE; @@ -2158,8 +2532,8 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) if (to->rank != from->rank) { gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must " - "have the same rank %d/%d", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + "have the same rank %d/%d", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &to->where, from->rank, to->rank); return FAILURE; } @@ -2167,8 +2541,9 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) if (to->ts.kind != from->ts.kind) { gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must " - "be of the same kind %d/%d", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + "be of the same kind %d/%d", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &to->where, from->ts.kind, to->ts.kind); return FAILURE; } @@ -2201,6 +2576,21 @@ gfc_check_new_line (gfc_expr *a) gfc_try +gfc_check_norm2 (gfc_expr *array, gfc_expr *dim) +{ + if (type_check (array, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (dim_rank_check (dim, array, false) == FAILURE) + return FAILURE; + + return SUCCESS; +} + +gfc_try gfc_check_null (gfc_expr *mold) { symbol_attribute attr; @@ -2216,7 +2606,7 @@ gfc_check_null (gfc_expr *mold) if (!attr.pointer && !attr.proc_pointer) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER", - gfc_current_intrinsic_arg[0], + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &mold->where); return FAILURE; } @@ -2236,8 +2626,8 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) if (gfc_check_conformance (array, mask, "arguments '%s' and '%s' for intrinsic '%s'", - gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[1], + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic) == FAILURE) return FAILURE; @@ -2266,7 +2656,8 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) if (mask->expr_type == EXPR_ARRAY) { - gfc_constructor *mask_ctor = mask->value.constructor; + gfc_constructor *mask_ctor; + mask_ctor = gfc_constructor_first (mask->value.constructor); while (mask_ctor) { if (mask_ctor->expr->expr_type != EXPR_CONSTANT) @@ -2278,7 +2669,7 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) if (mask_ctor->expr->value.logical) mask_true_values++; - mask_ctor = mask_ctor->next; + mask_ctor = gfc_constructor_next (mask_ctor); } } else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical) @@ -2289,8 +2680,9 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) gfc_error ("'%s' argument of '%s' intrinsic at %L must " "provide at least as many elements as there " "are .TRUE. values in '%s' (%ld/%d)", - gfc_current_intrinsic_arg[2],gfc_current_intrinsic, - &vector->where, gfc_current_intrinsic_arg[1], + gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic, &vector->where, + gfc_current_intrinsic_arg[1]->name, mpz_get_si (vector_size), mask_true_values); return FAILURE; } @@ -2307,15 +2699,26 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) gfc_try +gfc_check_parity (gfc_expr *mask, gfc_expr *dim) +{ + if (type_check (mask, 0, BT_LOGICAL) == FAILURE) + return FAILURE; + + if (array_check (mask, 0) == FAILURE) + return FAILURE; + + if (dim_rank_check (dim, mask, false) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +gfc_try gfc_check_precision (gfc_expr *x) { - if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type " - "REAL or COMPLEX", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic, &x->where); - return FAILURE; - } + if (real_or_complex_check (x, 0) == FAILURE) + return FAILURE; return SUCCESS; } @@ -2333,7 +2736,7 @@ gfc_check_present (gfc_expr *a) if (!sym->attr.dummy) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a " - "dummy variable", gfc_current_intrinsic_arg[0], + "dummy variable", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); return FAILURE; } @@ -2341,8 +2744,9 @@ gfc_check_present (gfc_expr *a) if (!sym->attr.optional) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be of " - "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic, &a->where); + "an OPTIONAL dummy variable", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &a->where); return FAILURE; } @@ -2357,7 +2761,7 @@ gfc_check_present (gfc_expr *a) && a->ref->u.ar.type == AR_FULL)) { gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a " - "subobject of '%s'", gfc_current_intrinsic_arg[0], + "subobject of '%s'", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where, sym->name); return FAILURE; } @@ -2492,7 +2896,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, if (shape_size <= 0) { gfc_error ("'%s' argument of '%s' intrinsic at %L is empty", - gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shape->where); return FAILURE; } @@ -2508,23 +2912,19 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, int i, extent; for (i = 0; i < shape_size; ++i) { - e = gfc_get_array_element (shape, i); + e = gfc_constructor_lookup_expr (shape->value.constructor, i); if (e->expr_type != EXPR_CONSTANT) - { - gfc_free_expr (e); - continue; - } + continue; gfc_extract_int (e, &extent); if (extent < 0) { gfc_error ("'%s' argument of '%s' intrinsic at %L has " - "negative element (%d)", gfc_current_intrinsic_arg[1], + "negative element (%d)", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &e->where, extent); return FAILURE; } - - gfc_free_expr (e); } } @@ -2561,7 +2961,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, { gfc_error ("'%s' argument of '%s' intrinsic at %L " "has wrong number of elements (%d/%d)", - gfc_current_intrinsic_arg[3], + gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic, &order->where, order_size, shape_size); return FAILURE; @@ -2569,12 +2969,9 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, for (i = 1; i <= order_size; ++i) { - e = gfc_get_array_element (order, i-1); + e = gfc_constructor_lookup_expr (order->value.constructor, i-1); if (e->expr_type != EXPR_CONSTANT) - { - gfc_free_expr (e); - continue; - } + continue; gfc_extract_int (e, &dim); @@ -2582,7 +2979,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, { gfc_error ("'%s' argument of '%s' intrinsic at %L " "has out-of-range dimension (%d)", - gfc_current_intrinsic_arg[3], + gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic, &e->where, dim); return FAILURE; } @@ -2591,13 +2988,13 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, { gfc_error ("'%s' argument of '%s' intrinsic at %L has " "invalid permutation of dimensions (dimension " - "'%d' duplicated)", gfc_current_intrinsic_arg[3], + "'%d' duplicated)", + gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic, &e->where, dim); return FAILURE; } perm[dim-1] = 1; - gfc_free_expr (e); } } } @@ -2613,9 +3010,10 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, gfc_constructor *c; bool test; - c = shape->value.constructor; + mpz_init_set_ui (size, 1); - for (; c; c = c->next) + for (c = gfc_constructor_first (shape->value.constructor); + c; c = gfc_constructor_next (c)) mpz_mul (size, size, c->expr->value.integer); test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0; @@ -2643,32 +3041,36 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS) { gfc_error ("'%s' argument of '%s' intrinsic at %L " - "must be of a derived type", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic, &a->where); + "must be of a derived type", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &a->where); return FAILURE; } if (!gfc_type_is_extensible (a->ts.u.derived)) { gfc_error ("'%s' argument of '%s' intrinsic at %L " - "must be of an extensible type", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic, &a->where); + "must be of an extensible type", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &a->where); return FAILURE; } if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS) { gfc_error ("'%s' argument of '%s' intrinsic at %L " - "must be of a derived type", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &b->where); + "must be of a derived type", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &b->where); return FAILURE; } if (!gfc_type_is_extensible (b->ts.u.derived)) { gfc_error ("'%s' argument of '%s' intrinsic at %L " - "must be of an extensible type", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &b->where); + "must be of an extensible type", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &b->where); return FAILURE; } @@ -2761,21 +3163,45 @@ gfc_check_selected_int_kind (gfc_expr *r) gfc_try -gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r) +gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix) { - if (p == NULL && r == NULL) + if (p == NULL && r == NULL + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SELECTED_REAL_KIND with" + " neither 'P' nor 'R' argument at %L", + gfc_current_intrinsic_where) == FAILURE) + return FAILURE; + + if (p) { - gfc_error ("Missing arguments to %s intrinsic at %L", - gfc_current_intrinsic, gfc_current_intrinsic_where); + if (type_check (p, 0, BT_INTEGER) == FAILURE) + return FAILURE; - return FAILURE; + if (scalar_check (p, 0) == FAILURE) + return FAILURE; } - if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (r) + { + if (type_check (r, 1, BT_INTEGER) == FAILURE) + return FAILURE; - if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (scalar_check (r, 1) == FAILURE) + return FAILURE; + } + + if (radix) + { + if (type_check (radix, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (radix, 1) == FAILURE) + return FAILURE; + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: '%s' intrinsic with " + "RADIX argument at %L", gfc_current_intrinsic, + &radix->where) == FAILURE) + return FAILURE; + } return SUCCESS; } @@ -2816,6 +3242,25 @@ gfc_check_shape (gfc_expr *source) gfc_try +gfc_check_shift (gfc_expr *i, gfc_expr *shift) +{ + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (shift, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (nonnegative_check ("SHIFT", shift) == FAILURE) + return FAILURE; + + if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +gfc_try gfc_check_sign (gfc_expr *a, gfc_expr *b) { if (int_or_real_check (a, 0) == FAILURE) @@ -2860,6 +3305,21 @@ 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]->name, 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) @@ -2871,6 +3331,20 @@ gfc_check_sleep_sub (gfc_expr *seconds) return SUCCESS; } +gfc_try +gfc_check_sngl (gfc_expr *a) +{ + if (type_check (a, 0, BT_REAL) == FAILURE) + return FAILURE; + + if ((a->ts.kind != gfc_default_double_kind) + && gfc_notify_std (GFC_STD_GNU, "GNU extension: non double precision" + "REAL argument to %s intrinsic at %L", + gfc_current_intrinsic, &a->where) == FAILURE) + return FAILURE; + + return SUCCESS; +} gfc_try gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) @@ -2878,7 +3352,7 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) if (source->rank >= GFC_MAX_DIMENSIONS) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be less " - "than rank %d", gfc_current_intrinsic_arg[0], + "than rank %d", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS); return FAILURE; @@ -2897,7 +3371,7 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0)) { gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid " - "dimension index", gfc_current_intrinsic_arg[1], + "dimension index", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &dim->where); return FAILURE; } @@ -3144,6 +3618,64 @@ gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) gfc_try +gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) +{ + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return FAILURE; + } + + if (coarray_check (coarray, 0) == FAILURE) + return FAILURE; + + if (sub->rank != 1) + { + gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L", + gfc_current_intrinsic_arg[1]->name, &sub->where); + return FAILURE; + } + + return SUCCESS; +} + + +gfc_try +gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim) +{ + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return FAILURE; + } + + if (dim != NULL && coarray == NULL) + { + gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE " + "intrinsic at %L", &dim->where); + return FAILURE; + } + + if (coarray == NULL) + return SUCCESS; + + if (coarray_check (coarray, 0) == FAILURE) + return FAILURE; + + if (dim != NULL) + { + if (dim_check (dim, 1, false) == FAILURE) + return FAILURE; + + if (dim_corank_check (dim, coarray) == FAILURE) + return FAILURE; + } + + return SUCCESS; +} + + +gfc_try gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED, gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size) { @@ -3204,6 +3736,34 @@ gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) gfc_try +gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) +{ + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return FAILURE; + } + + if (coarray_check (coarray, 0) == FAILURE) + return FAILURE; + + if (dim != NULL) + { + if (dim_check (dim, 1, false) == FAILURE) + return FAILURE; + + if (dim_corank_check (dim, coarray) == FAILURE) + return FAILURE; + } + + if (kind_check (kind, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +gfc_try gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) { mpz_t vector_size; @@ -3224,7 +3784,8 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) && gfc_array_size (vector, &vector_size) == SUCCESS) { int mask_true_count = 0; - gfc_constructor *mask_ctor = mask->value.constructor; + gfc_constructor *mask_ctor; + mask_ctor = gfc_constructor_first (mask->value.constructor); while (mask_ctor) { if (mask_ctor->expr->expr_type != EXPR_CONSTANT) @@ -3236,7 +3797,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) if (mask_ctor->expr->value.logical) mask_true_count++; - mask_ctor = mask_ctor->next; + mask_ctor = gfc_constructor_next (mask_ctor); } if (mpz_get_si (vector_size) < mask_true_count) @@ -3244,8 +3805,8 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) gfc_error ("'%s' argument of '%s' intrinsic at %L must " "provide at least as many elements as there " "are .TRUE. values in '%s' (%ld/%d)", - gfc_current_intrinsic_arg[0], gfc_current_intrinsic, - &vector->where, gfc_current_intrinsic_arg[1], + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &vector->where, gfc_current_intrinsic_arg[1]->name, mpz_get_si (vector_size), mask_true_count); return FAILURE; } @@ -3257,8 +3818,8 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) { gfc_error ("'%s' argument of '%s' intrinsic at %L must have " "the same rank as '%s' or be a scalar", - gfc_current_intrinsic_arg[2], gfc_current_intrinsic, - &field->where, gfc_current_intrinsic_arg[1]); + gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, + &field->where, gfc_current_intrinsic_arg[1]->name); return FAILURE; } @@ -3270,8 +3831,8 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) { gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L " "must have identical shape.", - gfc_current_intrinsic_arg[2], - gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &field->where); } } @@ -3438,6 +3999,22 @@ gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len, if (type_check (topos, 4, BT_INTEGER) == FAILURE) return FAILURE; + if (nonnegative_check ("frompos", frompos) == FAILURE) + return FAILURE; + + if (nonnegative_check ("topos", topos) == FAILURE) + return FAILURE; + + if (nonnegative_check ("len", len) == FAILURE) + return FAILURE; + + if (less_than_bitsize2 ("from", from, "frompos", frompos, "len", len) + == FAILURE) + return FAILURE; + + if (less_than_bitsize2 ("to", to, "topos", topos, "len", len) == FAILURE) + return FAILURE; + return SUCCESS; } @@ -3513,8 +4090,8 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) && mpz_get_ui (put_size) < kiss_size) gfc_error ("Size of '%s' argument of '%s' intrinsic at %L " "too small (%i/%i)", - gfc_current_intrinsic_arg[1], gfc_current_intrinsic, where, - (int) mpz_get_ui (put_size), kiss_size); + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + where, (int) mpz_get_ui (put_size), kiss_size); } if (get != NULL) @@ -3545,8 +4122,8 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) && mpz_get_ui (get_size) < kiss_size) gfc_error ("Size of '%s' argument of '%s' intrinsic at %L " "too small (%i/%i)", - gfc_current_intrinsic_arg[2], gfc_current_intrinsic, where, - (int) mpz_get_ui (get_size), kiss_size); + gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, + where, (int) mpz_get_ui (get_size), kiss_size); } /* RANDOM_SEED may not have more than one non-optional argument. */ @@ -3657,18 +4234,11 @@ gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status) { if (scalar_check (seconds, 0) == FAILURE) return FAILURE; - if (type_check (seconds, 0, BT_INTEGER) == FAILURE) return FAILURE; - if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " - "or PROCEDURE", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &handler->where); - return FAILURE; - } - + if (int_or_proc_check (handler, 1) == FAILURE) + return FAILURE; if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE) return FAILURE; @@ -3677,10 +4247,8 @@ gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status) if (scalar_check (status, 2) == FAILURE) return FAILURE; - if (type_check (status, 2, BT_INTEGER) == FAILURE) return FAILURE; - if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE) return FAILURE; @@ -3848,7 +4416,7 @@ gfc_check_getarg (gfc_expr *pos, gfc_expr *value) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind " "not wider than the default kind (%d)", - gfc_current_intrinsic_arg[0], gfc_current_intrinsic, + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &pos->where, gfc_default_integer_kind); return FAILURE; } @@ -4134,18 +4702,11 @@ gfc_check_signal (gfc_expr *number, gfc_expr *handler) { if (scalar_check (number, 0) == FAILURE) return FAILURE; - if (type_check (number, 0, BT_INTEGER) == FAILURE) return FAILURE; - if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " - "or PROCEDURE", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &handler->where); - return FAILURE; - } - + if (int_or_proc_check (handler, 1) == FAILURE) + return FAILURE; if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE) return FAILURE; @@ -4158,18 +4719,11 @@ gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status) { if (scalar_check (number, 0) == FAILURE) return FAILURE; - if (type_check (number, 0, BT_INTEGER) == FAILURE) return FAILURE; - if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE) - { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " - "or PROCEDURE", gfc_current_intrinsic_arg[1], - gfc_current_intrinsic, &handler->where); - return FAILURE; - } - + if (int_or_proc_check (handler, 1) == FAILURE) + return FAILURE; if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE) return FAILURE; @@ -4178,7 +4732,6 @@ gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status) if (type_check (status, 2, BT_INTEGER) == FAILURE) return FAILURE; - if (scalar_check (status, 2) == FAILURE) return FAILURE; @@ -4214,7 +4767,7 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " - "or LOGICAL", gfc_current_intrinsic_arg[0], + "or LOGICAL", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &i->where); return FAILURE; } @@ -4222,7 +4775,7 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " - "or LOGICAL", gfc_current_intrinsic_arg[1], + "or LOGICAL", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &j->where); return FAILURE; } @@ -4230,8 +4783,8 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) if (i->ts.type != j->ts.type) { gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must " - "have the same type", gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + "have the same type", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &j->where); return FAILURE; } @@ -4244,3 +4797,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]->name, gfc_current_intrinsic, + &kind->where); + return FAILURE; + } + + return SUCCESS; +} diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c new file mode 100644 index 00000000000..218247dbfaa --- /dev/null +++ b/gcc/fortran/class.c @@ -0,0 +1,616 @@ +/* Implementation of Fortran 2003 Polymorphism. + Copyright (C) 2009, 2010 + Free Software Foundation, Inc. + Contributed by Paul Richard Thomas & Janus Weil + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +<http://www.gnu.org/licenses/>. */ + + +/* class.c -- This file contains the front end functions needed to service + the implementation of Fortran 2003 polymorphism and other + object-oriented features. */ + + +/* Outline of the internal representation: + + Each CLASS variable is encapsulated by a class container, which is a + structure with two fields: + * $data: A pointer to the actual data of the variable. This field has the + declared type of the class variable and its attributes + (pointer/allocatable/dimension/...). + * $vptr: A pointer to the vtable entry (see below) of the dynamic type. + + For each derived type we set up a "vtable" entry, i.e. a structure with the + following fields: + * $hash: A hash value serving as a unique identifier for this type. + * $size: The size in bytes of the derived type. + * $extends: A pointer to the vtable entry of the parent derived type. + In addition to these fields, each vtable entry contains additional procedure + pointer components, which contain pointers to the procedures which are bound + to the type's "methods" (type-bound procedures). */ + + +#include "config.h" +#include "system.h" +#include "gfortran.h" +#include "constructor.h" + + +/* Insert a reference to the component of the given name. + Only to be used with CLASS containers. */ + +void +gfc_add_component_ref (gfc_expr *e, const char *name) +{ + gfc_ref **tail = &(e->ref); + gfc_ref *next = NULL; + gfc_symbol *derived = e->symtree->n.sym->ts.u.derived; + while (*tail != NULL) + { + if ((*tail)->type == REF_COMPONENT) + derived = (*tail)->u.c.component->ts.u.derived; + if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL) + break; + tail = &((*tail)->next); + } + if (*tail != NULL && strcmp (name, "$data") == 0) + next = *tail; + (*tail) = gfc_get_ref(); + (*tail)->next = next; + (*tail)->type = REF_COMPONENT; + (*tail)->u.c.sym = derived; + (*tail)->u.c.component = gfc_find_component (derived, name, true, true); + gcc_assert((*tail)->u.c.component); + if (!next) + e->ts = (*tail)->u.c.component->ts; +} + + +/* Build a NULL initializer for CLASS pointers, + initializing the $data and $vptr components to zero. */ + +gfc_expr * +gfc_class_null_initializer (gfc_typespec *ts) +{ + gfc_expr *init; + gfc_component *comp; + + init = gfc_get_structure_constructor_expr (ts->type, ts->kind, + &ts->u.derived->declared_at); + init->ts = *ts; + + for (comp = ts->u.derived->components; comp; comp = comp->next) + { + gfc_constructor *ctor = gfc_constructor_get(); + ctor->expr = gfc_get_expr (); + ctor->expr->expr_type = EXPR_NULL; + ctor->expr->ts = comp->ts; + gfc_constructor_append (&init->value.constructor, ctor); + } + + return init; +} + + +/* Build a polymorphic CLASS entity, using the symbol that comes from + build_sym. A CLASS entity is represented by an encapsulating type, + which contains the declared type as '$data' component, plus a pointer + component '$vptr' which determines the dynamic type. */ + +gfc_try +gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, + gfc_array_spec **as, bool delayed_vtab) +{ + char name[GFC_MAX_SYMBOL_LEN + 5]; + gfc_symbol *fclass; + gfc_symbol *vtab; + gfc_component *c; + + /* Determine the name of the encapsulating type. */ + if ((*as) && (*as)->rank && attr->allocatable) + sprintf (name, "class$%s_%d_a", ts->u.derived->name, (*as)->rank); + else if ((*as) && (*as)->rank) + sprintf (name, "class$%s_%d", ts->u.derived->name, (*as)->rank); + else if (attr->pointer) + sprintf (name, "class$%s_p", ts->u.derived->name); + else if (attr->allocatable) + sprintf (name, "class$%s_a", ts->u.derived->name); + else + sprintf (name, "class$%s", ts->u.derived->name); + + gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass); + if (fclass == NULL) + { + gfc_symtree *st; + /* If not there, create a new symbol. */ + fclass = gfc_new_symbol (name, ts->u.derived->ns); + st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name); + st->n.sym = fclass; + gfc_set_sym_referenced (fclass); + fclass->refs++; + fclass->ts.type = BT_UNKNOWN; + fclass->attr.abstract = ts->u.derived->attr.abstract; + if (ts->u.derived->f2k_derived) + fclass->f2k_derived = gfc_get_namespace (NULL, 0); + if (gfc_add_flavor (&fclass->attr, FL_DERIVED, + NULL, &gfc_current_locus) == FAILURE) + return FAILURE; + + /* Add component '$data'. */ + if (gfc_add_component (fclass, "$data", &c) == FAILURE) + return FAILURE; + c->ts = *ts; + c->ts.type = BT_DERIVED; + c->attr.access = ACCESS_PRIVATE; + c->ts.u.derived = ts->u.derived; + c->attr.class_pointer = attr->pointer; + c->attr.pointer = attr->pointer || attr->dummy; + c->attr.allocatable = attr->allocatable; + c->attr.dimension = attr->dimension; + c->attr.codimension = attr->codimension; + c->attr.abstract = ts->u.derived->attr.abstract; + c->as = (*as); + c->initializer = NULL; + + /* Add component '$vptr'. */ + if (gfc_add_component (fclass, "$vptr", &c) == FAILURE) + return FAILURE; + c->ts.type = BT_DERIVED; + if (delayed_vtab) + c->ts.u.derived = NULL; + else + { + vtab = gfc_find_derived_vtab (ts->u.derived); + gcc_assert (vtab); + c->ts.u.derived = vtab->ts.u.derived; + } + c->attr.access = ACCESS_PRIVATE; + c->attr.pointer = 1; + } + + /* Since the extension field is 8 bit wide, we can only have + up to 255 extension levels. */ + if (ts->u.derived->attr.extension == 255) + { + gfc_error ("Maximum extension level reached with type '%s' at %L", + ts->u.derived->name, &ts->u.derived->declared_at); + return FAILURE; + } + + fclass->attr.extension = ts->u.derived->attr.extension + 1; + fclass->attr.is_class = 1; + ts->u.derived = fclass; + attr->allocatable = attr->pointer = attr->dimension = 0; + (*as) = NULL; /* XXX */ + return SUCCESS; +} + + +/* Add a procedure pointer component to the vtype + to represent a specific type-bound procedure. */ + +static void +add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb) +{ + gfc_component *c; + c = gfc_find_component (vtype, name, true, true); + + if (c == NULL) + { + /* Add procedure component. */ + if (gfc_add_component (vtype, name, &c) == FAILURE) + return; + + 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; + } + else if (c->attr.proc_pointer && c->tb) + { + *c->tb = *tb; + c->tb->ppc = 1; + } + + if (tb->u.specific) + { + c->ts.interface = tb->u.specific->n.sym; + if (!tb->deferred) + c->initializer = gfc_get_variable_expr (tb->u.specific); + } +} + + +/* 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) +{ + if (!st) + return; + + if (st->left) + add_procs_to_declared_vtab1 (st->left, vtype); + + if (st->right) + add_procs_to_declared_vtab1 (st->right, vtype); + + if (st->n.tb && !st->n.tb->error + && !st->n.tb->is_generic && st->n.tb->u.specific) + 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) +{ + gfc_component *cmp; + gfc_symbol *vtab; + + 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; + + add_proc_comp (vtype, cmp->name, cmp->tb); + } +} + + +/* Add procedure pointers for all type-bound procedures to a vtab. */ + +static void +add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype) +{ + gfc_symbol* super_type; + + super_type = gfc_get_derived_super_type (derived); + + if (super_type && (super_type != derived)) + { + /* 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 initializers right. */ + add_procs_to_declared_vtab (super_type, vtype); + } + + if (derived->f2k_derived && derived->f2k_derived->tb_sym_root) + add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype); + + 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 + After these follow procedure pointer components for the + specific type-bound procedures. */ + +gfc_symbol * +gfc_find_derived_vtab (gfc_symbol *derived) +{ + gfc_namespace *ns; + gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; + char name[2 * GFC_MAX_SYMBOL_LEN + 8]; + + /* Find the top-level namespace (MODULE or PROGRAM). */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + if (!ns->parent) + break; + + /* If the type is a class container, use the underlying derived type. */ + if (derived->attr.is_class) + derived = gfc_get_derived_super_type (derived); + + if (ns) + { + sprintf (name, "vtab$%s", derived->name); + gfc_find_symbol (name, ns, 0, &vtab); + + if (vtab == NULL) + { + gfc_get_symbol (name, ns, &vtab); + vtab->ts.type = BT_DERIVED; + if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL, + &gfc_current_locus) == FAILURE) + goto cleanup; + vtab->attr.target = 1; + vtab->attr.save = SAVE_EXPLICIT; + vtab->attr.vtab = 1; + vtab->attr.access = ACCESS_PUBLIC; + gfc_set_sym_referenced (vtab); + sprintf (name, "vtype$%s", derived->name); + + gfc_find_symbol (name, ns, 0, &vtype); + if (vtype == NULL) + { + gfc_component *c; + gfc_symbol *parent = NULL, *parent_vtab = NULL; + + gfc_get_symbol (name, ns, &vtype); + if (gfc_add_flavor (&vtype->attr, FL_DERIVED, + NULL, &gfc_current_locus) == FAILURE) + goto cleanup; + vtype->attr.access = ACCESS_PUBLIC; + gfc_set_sym_referenced (vtype); + + /* Add component '$hash'. */ + if (gfc_add_component (vtype, "$hash", &c) == FAILURE) + goto cleanup; + c->ts.type = BT_INTEGER; + c->ts.kind = 4; + c->attr.access = ACCESS_PRIVATE; + c->initializer = gfc_get_int_expr (gfc_default_integer_kind, + NULL, derived->hash_value); + + /* Add component '$size'. */ + if (gfc_add_component (vtype, "$size", &c) == FAILURE) + goto cleanup; + c->ts.type = BT_INTEGER; + c->ts.kind = 4; + c->attr.access = ACCESS_PRIVATE; + /* Remember the derived type in ts.u.derived, + so that the correct initializer can be set later on + (in gfc_conv_structure). */ + c->ts.u.derived = derived; + c->initializer = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 0); + + /* Add component $extends. */ + if (gfc_add_component (vtype, "$extends", &c) == FAILURE) + goto cleanup; + c->attr.pointer = 1; + c->attr.access = ACCESS_PRIVATE; + parent = gfc_get_derived_super_type (derived); + if (parent) + { + 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 (); + c->initializer->expr_type = EXPR_VARIABLE; + gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, + 0, &c->initializer->symtree); + } + else + { + c->ts.type = BT_DERIVED; + c->ts.u.derived = vtype; + c->initializer = gfc_get_null_expr (NULL); + } + + /* Add component $def_init. */ + if (gfc_add_component (vtype, "$def_init", &c) == FAILURE) + goto cleanup; + c->attr.pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->ts.type = BT_DERIVED; + c->ts.u.derived = derived; + if (derived->attr.abstract) + c->initializer = NULL; + else + { + /* Construct default initialization variable. */ + sprintf (name, "def_init$%s", derived->name); + gfc_get_symbol (name, ns, &def_init); + def_init->attr.target = 1; + def_init->attr.save = SAVE_EXPLICIT; + def_init->attr.access = ACCESS_PUBLIC; + def_init->attr.flavor = FL_VARIABLE; + gfc_set_sym_referenced (def_init); + def_init->ts.type = BT_DERIVED; + def_init->ts.u.derived = derived; + def_init->value = gfc_default_initializer (&def_init->ts); + + c->initializer = gfc_lval_expr_from_sym (def_init); + } + + /* Add procedure pointers for type-bound procedures. */ + add_procs_to_declared_vtab (derived, vtype); + vtype->attr.vtype = 1; + } + + vtab->ts.u.derived = vtype; + vtab->value = gfc_default_initializer (&vtab->ts); + } + } + + found_sym = vtab; + +cleanup: + /* It is unexpected to have some symbols added at resolution or code + generation time. We commit the changes in order to keep a clean state. */ + if (found_sym) + { + gfc_commit_symbol (vtab); + if (vtype) + gfc_commit_symbol (vtype); + if (def_init) + gfc_commit_symbol (def_init); + } + else + gfc_undo_symbols (); + + return found_sym; +} + + +/* General worker function to find either a type-bound procedure or a + type-bound user operator. */ + +static gfc_symtree* +find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, + const char* name, bool noaccess, bool uop, + locus* where) +{ + gfc_symtree* res; + gfc_symtree* root; + + /* Set correct symbol-root. */ + gcc_assert (derived->f2k_derived); + root = (uop ? derived->f2k_derived->tb_uop_root + : derived->f2k_derived->tb_sym_root); + + /* Set default to failure. */ + if (t) + *t = FAILURE; + + /* Try to find it in the current type's namespace. */ + res = gfc_find_symtree (root, name); + if (res && res->n.tb && !res->n.tb->error) + { + /* We found one. */ + if (t) + *t = SUCCESS; + + if (!noaccess && derived->attr.use_assoc + && res->n.tb->access == ACCESS_PRIVATE) + { + if (where) + gfc_error ("'%s' of '%s' is PRIVATE at %L", + name, derived->name, where); + if (t) + *t = FAILURE; + } + + return res; + } + + /* Otherwise, recurse on parent type if derived is an extension. */ + if (derived->attr.extension) + { + gfc_symbol* super_type; + super_type = gfc_get_derived_super_type (derived); + gcc_assert (super_type); + + return find_typebound_proc_uop (super_type, t, name, + noaccess, uop, where); + } + + /* Nothing found. */ + return NULL; +} + + +/* Find a type-bound procedure or user operator by name for a derived-type + (looking recursively through the super-types). */ + +gfc_symtree* +gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t, + const char* name, bool noaccess, locus* where) +{ + return find_typebound_proc_uop (derived, t, name, noaccess, false, where); +} + +gfc_symtree* +gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t, + const char* name, bool noaccess, locus* where) +{ + return find_typebound_proc_uop (derived, t, name, noaccess, true, where); +} + + +/* Find a type-bound intrinsic operator looking recursively through the + super-type hierarchy. */ + +gfc_typebound_proc* +gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, + gfc_intrinsic_op op, bool noaccess, + locus* where) +{ + gfc_typebound_proc* res; + + /* Set default to failure. */ + if (t) + *t = FAILURE; + + /* Try to find it in the current type's namespace. */ + if (derived->f2k_derived) + res = derived->f2k_derived->tb_op[op]; + else + res = NULL; + + /* Check access. */ + if (res && !res->error) + { + /* We found one. */ + if (t) + *t = SUCCESS; + + if (!noaccess && derived->attr.use_assoc + && res->access == ACCESS_PRIVATE) + { + if (where) + gfc_error ("'%s' of '%s' is PRIVATE at %L", + gfc_op2string (op), derived->name, where); + if (t) + *t = FAILURE; + } + + return res; + } + + /* Otherwise, recurse on parent type if derived is an extension. */ + if (derived->attr.extension) + { + gfc_symbol* super_type; + super_type = gfc_get_derived_super_type (derived); + gcc_assert (super_type); + + return gfc_find_typebound_intrinsic_op (super_type, t, op, + noaccess, where); + } + + /* Nothing found. */ + return NULL; +} + + +/* Get a typebound-procedure symtree or create and insert it if not yet + present. This is like a very simplified version of gfc_get_sym_tree for + tbp-symtrees rather than regular ones. */ + +gfc_symtree* +gfc_get_tbp_symtree (gfc_symtree **root, const char *name) +{ + gfc_symtree *result; + + result = gfc_find_symtree (*root, name); + if (!result) + { + result = gfc_new_symtree (root, name); + gcc_assert (result); + result->n.tb = NULL; + } + + return result; +} 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/constructor.c b/gcc/fortran/constructor.c new file mode 100644 index 00000000000..45228b0c47c --- /dev/null +++ b/gcc/fortran/constructor.c @@ -0,0 +1,234 @@ +/* Array and structure constructors + Copyright (C) 2009, 2010 + Free Software Foundation, Inc. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +<http://www.gnu.org/licenses/>. */ + +#include "config.h" +#include "system.h" +#include "gfortran.h" +#include "constructor.h" + + +static void +node_free (splay_tree_value value) +{ + gfc_constructor *c = (gfc_constructor*)value; + + if (c->expr) + gfc_free_expr (c->expr); + + if (c->iterator) + gfc_free_iterator (c->iterator, 1); + + mpz_clear (c->offset); + + gfc_free (c); +} + + +static gfc_constructor * +node_copy (splay_tree_node node, void *base) +{ + gfc_constructor *c, *src = (gfc_constructor*)node->value; + + c = XCNEW (gfc_constructor); + c->base = (gfc_constructor_base)base; + c->expr = gfc_copy_expr (src->expr); + c->iterator = gfc_copy_iterator (src->iterator); + c->where = src->where; + c->n.component = src->n.component; + + mpz_init_set (c->offset, src->offset); + + return c; +} + + +static int +node_copy_and_insert (splay_tree_node node, void *base) +{ + int n = mpz_get_si (((gfc_constructor*)node->value)->offset); + gfc_constructor_insert ((gfc_constructor_base*)base, + node_copy (node, base), n); + return 0; +} + + +gfc_constructor * +gfc_constructor_get (void) +{ + gfc_constructor *c = XCNEW (gfc_constructor); + c->base = NULL; + c->expr = NULL; + c->iterator = NULL; + + mpz_init_set_si (c->offset, 0); + + return c; +} + +gfc_constructor_base gfc_constructor_get_base (void) +{ + return splay_tree_new (splay_tree_compare_ints, NULL, node_free); +} + + +gfc_constructor_base +gfc_constructor_copy (gfc_constructor_base base) +{ + gfc_constructor_base new_base; + + if (!base) + return NULL; + + new_base = gfc_constructor_get_base (); + splay_tree_foreach (base, node_copy_and_insert, &new_base); + + return new_base; +} + + +void +gfc_constructor_free (gfc_constructor_base base) +{ + if (base) + splay_tree_delete (base); +} + + +gfc_constructor * +gfc_constructor_append (gfc_constructor_base *base, gfc_constructor *c) +{ + int offset = 0; + if (*base) + offset = (int)(splay_tree_max (*base)->key) + 1; + + return gfc_constructor_insert (base, c, offset); +} + + +gfc_constructor * +gfc_constructor_append_expr (gfc_constructor_base *base, + gfc_expr *e, locus *where) +{ + gfc_constructor *c = gfc_constructor_get (); + c->expr = e; + if (where) + c->where = *where; + + return gfc_constructor_append (base, c); +} + + +gfc_constructor * +gfc_constructor_insert (gfc_constructor_base *base, gfc_constructor *c, int n) +{ + splay_tree_node node; + + if (*base == NULL) + *base = splay_tree_new (splay_tree_compare_ints, NULL, node_free); + + c->base = *base; + mpz_set_si (c->offset, n); + + node = splay_tree_insert (*base, (splay_tree_key) n, (splay_tree_value) c); + gcc_assert (node); + + return (gfc_constructor*)node->value; +} + + +gfc_constructor * +gfc_constructor_insert_expr (gfc_constructor_base *base, + gfc_expr *e, locus *where, int n) +{ + gfc_constructor *c = gfc_constructor_get (); + c->expr = e; + if (where) + c->where = *where; + + return gfc_constructor_insert (base, c, n); +} + + +gfc_constructor * +gfc_constructor_lookup (gfc_constructor_base base, int offset) +{ + splay_tree_node node; + + if (!base) + return NULL; + + node = splay_tree_lookup (base, (splay_tree_key) offset); + if (node) + return (gfc_constructor*) node->value; + + return NULL; +} + + +gfc_expr * +gfc_constructor_lookup_expr (gfc_constructor_base base, int offset) +{ + gfc_constructor *c = gfc_constructor_lookup (base, offset); + return c ? c->expr : NULL; +} + + +int +gfc_constructor_expr_foreach (gfc_constructor *ctor ATTRIBUTE_UNUSED, + int(*f)(gfc_expr *) ATTRIBUTE_UNUSED) +{ + gcc_assert (0); + return 0; +} + +void +gfc_constructor_swap (gfc_constructor *ctor ATTRIBUTE_UNUSED, + int n ATTRIBUTE_UNUSED, int m ATTRIBUTE_UNUSED) +{ + gcc_assert (0); +} + + + +gfc_constructor * +gfc_constructor_first (gfc_constructor_base base) +{ + if (base) + { + splay_tree_node node = splay_tree_min (base); + return node ? (gfc_constructor*) node->value : NULL; + } + else + return NULL; +} + + +gfc_constructor * +gfc_constructor_next (gfc_constructor *ctor) +{ + if (ctor) + { + splay_tree_node node = splay_tree_successor (ctor->base, + mpz_get_si (ctor->offset)); + return node ? (gfc_constructor*) node->value : NULL; + } + else + return NULL; +} diff --git a/gcc/fortran/constructor.h b/gcc/fortran/constructor.h new file mode 100644 index 00000000000..558de7f180a --- /dev/null +++ b/gcc/fortran/constructor.h @@ -0,0 +1,86 @@ +/* Array and structure constructors + Copyright (C) 2009, 2010 + Free Software Foundation, Inc. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +<http://www.gnu.org/licenses/>. */ + +#ifndef GFC_CONSTRUCTOR_H +#define GFC_CONSTRUCTOR_H + +/* Get a new constructor structure. */ +gfc_constructor *gfc_constructor_get (void); + +gfc_constructor_base gfc_constructor_get_base (void); + +/* Copy a constructor structure. */ +gfc_constructor_base gfc_constructor_copy (gfc_constructor_base base); + + +/* Free a gfc_constructor structure. */ +void gfc_constructor_free (gfc_constructor_base base); + + +/* Given an constructor structure, append the expression node onto + the constructor. Returns the constructor node appended. */ +gfc_constructor *gfc_constructor_append (gfc_constructor_base *base, + gfc_constructor *c); + +gfc_constructor *gfc_constructor_append_expr (gfc_constructor_base *base, + gfc_expr *e, locus *where); + + +/* Given an constructor structure, place the expression node at position. + Returns the constructor node inserted. */ +gfc_constructor *gfc_constructor_insert (gfc_constructor_base *base, + gfc_constructor *c, int n); + +gfc_constructor *gfc_constructor_insert_expr (gfc_constructor_base *base, + gfc_expr *e, locus *where, + int n); + +/* Given an array constructor expression and an element number (starting + at zero), return a pointer to the array element. NULL is returned if + the size of the array has been exceeded. The expression node returned + remains a part of the array and should not be freed. */ + +gfc_constructor *gfc_constructor_lookup (gfc_constructor_base base, int n); + +/* Convenience function. Same as ... + gfc_constructor *c = gfc_constructor_lookup (base, n); + gfc_expr *e = c ? c->expr : NULL; +*/ +gfc_expr *gfc_constructor_lookup_expr (gfc_constructor_base base, int n); + + +int gfc_constructor_expr_foreach (gfc_constructor *ctor, int(*)(gfc_expr *)); + + +void gfc_constructor_swap (gfc_constructor *ctor, int n, int m); + + + +/* Get the first constructor node in the constructure structure. + Returns NULL if there is no such expression. */ +gfc_constructor *gfc_constructor_first (gfc_constructor_base base); + +/* Get the next constructor node in the constructure structure. + Returns NULL if there is no next expression. */ +gfc_constructor *gfc_constructor_next (gfc_constructor *ctor); + +gfc_constructor *gfc_constructor_advance (gfc_constructor *ctor, int n); + +#endif /* GFC_CONSTRUCTOR_H */ diff --git a/gcc/fortran/convert.c b/gcc/fortran/convert.c index 1e7d090cbf1..0493f3fd573 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" +#include "diagnostic-core.h" /* For error. */ #include "gfortran.h" #include "trans.h" @@ -80,7 +80,7 @@ convert (tree type, tree expr) return expr; if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (expr))) - return fold_build1 (NOP_EXPR, type, expr); + return fold_build1_loc (input_location, NOP_EXPR, type, expr); if (TREE_CODE (TREE_TYPE (expr)) == ERROR_MARK) return error_mark_node; if (TREE_CODE (TREE_TYPE (expr)) == VOID_TYPE) @@ -89,7 +89,7 @@ convert (tree type, tree expr) return error_mark_node; } if (code == VOID_TYPE) - return fold_build1 (CONVERT_EXPR, type, e); + return fold_build1_loc (input_location, CONVERT_EXPR, type, e); #if 0 /* This is incorrect. A truncation can't be stripped this way. Extensions will be stripped by the use of get_unwidened. */ @@ -105,9 +105,10 @@ convert (tree type, tree expr) /* If we have a NOP_EXPR, we must fold it here to avoid infinite recursion between fold () and convert (). */ if (TREE_CODE (e) == NOP_EXPR) - return fold_build1 (NOP_EXPR, type, TREE_OPERAND (e, 0)); + return fold_build1_loc (input_location, NOP_EXPR, type, + TREE_OPERAND (e, 0)); else - return fold_build1 (NOP_EXPR, type, e); + return fold_build1_loc (input_location, NOP_EXPR, type, e); } if (code == POINTER_TYPE || code == REFERENCE_TYPE) return fold (convert_to_pointer (type, e)); diff --git a/gcc/fortran/cpp.c b/gcc/fortran/cpp.c index ec8bb59504c..a6a922f0ff9 100644 --- a/gcc/fortran/cpp.c +++ b/gcc/fortran/cpp.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc. This file is part of GCC. @@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see #include "../../libcpp/internal.h" #include "cpp.h" #include "incpath.h" +#include "mkdeps.h" #ifndef TARGET_OS_CPP_BUILTINS # define TARGET_OS_CPP_BUILTINS() @@ -84,6 +85,12 @@ struct gfc_cpp_option_data int no_predefined; /* -undef */ int standard_include_paths; /* -nostdinc */ int verbose; /* -v */ + int deps; /* -M */ + int deps_skip_system; /* -MM */ + const char *deps_filename; /* -M[M]D */ + const char *deps_filename_user; /* -MF <arg> */ + int deps_missing_are_generated; /* -MG */ + int deps_phony; /* -MP */ const char *multilib; /* -imultilib <dir> */ const char *prefix; /* -iprefix <dir> */ @@ -137,9 +144,9 @@ static void cb_include (cpp_reader *, source_location, const unsigned char *, static void cb_ident (cpp_reader *, source_location, const cpp_string *); static void cb_used_define (cpp_reader *, source_location, cpp_hashnode *); static void cb_used_undef (cpp_reader *, source_location, cpp_hashnode *); -static bool cb_cpp_error (cpp_reader *, int, location_t, unsigned int, +static bool cb_cpp_error (cpp_reader *, int, int, location_t, unsigned int, const char *, va_list *) - ATTRIBUTE_GCC_DIAG(5,0); + ATTRIBUTE_GCC_DIAG(6,0); void pp_dir_change (cpp_reader *, const char *); static int dump_macro (cpp_reader *, cpp_hashnode *, void *); @@ -270,6 +277,26 @@ gfc_cpp_preprocess_only (void) return gfc_cpp_option.preprocess_only; } +bool +gfc_cpp_makedep (void) +{ + return gfc_cpp_option.deps; +} + +void +gfc_cpp_add_dep (const char *name, bool system) +{ + if (!gfc_cpp_option.deps_skip_system || !system) + deps_add_dep (cpp_get_deps (cpp_in), name); +} + +void +gfc_cpp_add_target (const char *name) +{ + deps_add_target (cpp_get_deps (cpp_in), name, 0); +} + + const char * gfc_cpp_temporary_file (void) { @@ -277,8 +304,8 @@ gfc_cpp_temporary_file (void) } void -gfc_cpp_init_options (unsigned int argc, - const char **argv ATTRIBUTE_UNUSED) +gfc_cpp_init_options (unsigned int decoded_options_count, + struct cl_decoded_option *decoded_options ATTRIBUTE_UNUSED) { /* Do not create any objects from libcpp here. If no preprocessing is requested, this would be wasted @@ -299,12 +326,19 @@ gfc_cpp_init_options (unsigned int argc, gfc_cpp_option.no_predefined = 0; gfc_cpp_option.standard_include_paths = 1; gfc_cpp_option.verbose = 0; + gfc_cpp_option.deps = 0; + gfc_cpp_option.deps_skip_system = 0; + gfc_cpp_option.deps_phony = 0; + gfc_cpp_option.deps_missing_are_generated = 0; + gfc_cpp_option.deps_filename = NULL; + gfc_cpp_option.deps_filename_user = NULL; gfc_cpp_option.multilib = NULL; gfc_cpp_option.prefix = NULL; gfc_cpp_option.sysroot = NULL; - gfc_cpp_option.deferred_opt = XNEWVEC (gfc_cpp_deferred_opt_t, argc); + gfc_cpp_option.deferred_opt = XNEWVEC (gfc_cpp_deferred_opt_t, + decoded_options_count); gfc_cpp_option.deferred_opt_count = 0; } @@ -320,7 +354,7 @@ gfc_cpp_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED result = 0; break; - case OPT_cpp: + case OPT_cpp_: gfc_cpp_option.temporary_filename = arg; break; @@ -414,6 +448,43 @@ gfc_cpp_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED gfc_cpp_option.print_include_names = 1; break; + case OPT_MM: + gfc_cpp_option.deps_skip_system = 1; + /* fall through */ + + case OPT_M: + gfc_cpp_option.deps = 1; + break; + + case OPT_MMD: + gfc_cpp_option.deps_skip_system = 1; + /* fall through */ + + case OPT_MD: + gfc_cpp_option.deps = 1; + gfc_cpp_option.deps_filename = arg; + break; + + case OPT_MF: + /* If specified multiple times, last one wins. */ + gfc_cpp_option.deps_filename_user = arg; + break; + + case OPT_MG: + gfc_cpp_option.deps_missing_are_generated = 1; + break; + + case OPT_MP: + gfc_cpp_option.deps_phony = 1; + break; + + case OPT_MQ: + case OPT_MT: + gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].code = code; + gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].arg = arg; + gfc_cpp_option.deferred_opt_count++; + break; + case OPT_P: gfc_cpp_option.no_line_commands = 1; break; @@ -430,16 +501,17 @@ gfc_cpp_post_options (void) an error. */ if (!gfc_cpp_enabled () && (gfc_cpp_preprocess_only () - || !gfc_cpp_option.discard_comments - || !gfc_cpp_option.discard_comments_in_macro_exp - || gfc_cpp_option.print_include_names - || gfc_cpp_option.no_line_commands - || gfc_cpp_option.dump_macros - || gfc_cpp_option.dump_includes)) + || gfc_cpp_makedep () + || !gfc_cpp_option.discard_comments + || !gfc_cpp_option.discard_comments_in_macro_exp + || gfc_cpp_option.print_include_names + || gfc_cpp_option.no_line_commands + || gfc_cpp_option.dump_macros + || gfc_cpp_option.dump_includes)) gfc_fatal_error("To enable preprocessing, use -cpp"); cpp_in = cpp_create_reader (CLK_GNUC89, NULL, line_table); - if (!gfc_cpp_enabled()) + if (!gfc_cpp_enabled ()) return; gcc_assert (cpp_in); @@ -462,6 +534,17 @@ gfc_cpp_post_options (void) cpp_option->print_include_names = gfc_cpp_option.print_include_names; cpp_option->preprocessed = gfc_option.flag_preprocessed; + if (gfc_cpp_makedep ()) + { + cpp_option->deps.style = DEPS_USER; + cpp_option->deps.phony_targets = gfc_cpp_option.deps_phony; + cpp_option->deps.missing_files = gfc_cpp_option.deps_missing_are_generated; + + /* -MF <arg> overrides -M[M]D. */ + if (gfc_cpp_option.deps_filename_user) + gfc_cpp_option.deps_filename = gfc_cpp_option.deps_filename_user; + } + if (gfc_cpp_option.working_directory == -1) gfc_cpp_option.working_directory = (debug_info_level != DINFO_LEVEL_NONE); @@ -523,7 +606,8 @@ gfc_cpp_init_0 (void) print.outf = fopen (gfc_cpp_option.output_filename, "w"); if (print.outf == NULL) gfc_fatal_error ("opening output file %s: %s", - gfc_cpp_option.output_filename, strerror(errno)); + gfc_cpp_option.output_filename, + xstrerror (errno)); } else print.outf = stdout; @@ -533,7 +617,7 @@ gfc_cpp_init_0 (void) print.outf = fopen (gfc_cpp_option.temporary_filename, "w"); if (print.outf == NULL) gfc_fatal_error ("opening output file %s: %s", - gfc_cpp_option.temporary_filename, strerror(errno)); + gfc_cpp_option.temporary_filename, xstrerror (errno)); } gcc_assert(cpp_in); @@ -571,6 +655,9 @@ gfc_cpp_init (void) else cpp_assert (cpp_in, opt->arg); } + else if (opt->code == OPT_MT || opt->code == OPT_MQ) + deps_add_target (cpp_get_deps (cpp_in), + opt->arg, opt->code == OPT_MQ); } if (gfc_cpp_option.working_directory @@ -614,14 +701,27 @@ gfc_cpp_done (void) if (!gfc_cpp_enabled ()) return; - /* TODO: if dependency tracking was enabled, call - cpp_finish() here to write dependencies. + gcc_assert (cpp_in); - Use cpp_get_deps() to access the current source's - dependencies during parsing. Add dependencies using - the mkdeps-interface (defined in libcpp). */ + if (gfc_cpp_makedep ()) + { + if (gfc_cpp_option.deps_filename) + { + FILE *f = fopen (gfc_cpp_option.deps_filename, "w"); + if (f) + { + cpp_finish (cpp_in, f); + fclose (f); + } + else + gfc_fatal_error ("opening output file %s: %s", + gfc_cpp_option.deps_filename, + xstrerror (errno)); + } + else + cpp_finish (cpp_in, stdout); + } - gcc_assert (cpp_in); cpp_undef_all (cpp_in); cpp_clear_file_cache (cpp_in); } @@ -962,25 +1062,26 @@ cb_used_define (cpp_reader *pfile, source_location line ATTRIBUTE_UNUSED, } /* Callback from cpp_error for PFILE to print diagnostics from the - preprocessor. The diagnostic is of type LEVEL, at location + preprocessor. The diagnostic is of type LEVEL, with REASON set + to the reason code if LEVEL is represents a warning, at location LOCATION, with column number possibly overridden by COLUMN_OVERRIDE if not zero; MSG is the translated message and AP the arguments. Returns true if a diagnostic was emitted, false otherwise. */ static bool -cb_cpp_error (cpp_reader *pfile ATTRIBUTE_UNUSED, int level, +cb_cpp_error (cpp_reader *pfile ATTRIBUTE_UNUSED, int level, int reason, location_t location, unsigned int column_override, const char *msg, va_list *ap) { diagnostic_info diagnostic; diagnostic_t dlevel; - int save_warn_system_headers = warn_system_headers; + bool save_warn_system_headers = global_dc->warn_system_headers; bool ret; switch (level) { case CPP_DL_WARNING_SYSHDR: - warn_system_headers = 1; + global_dc->warn_system_headers = 1; /* Fall through. */ case CPP_DL_WARNING: dlevel = DK_WARNING; @@ -1007,9 +1108,11 @@ cb_cpp_error (cpp_reader *pfile ATTRIBUTE_UNUSED, int level, location, dlevel); if (column_override) diagnostic_override_column (&diagnostic, column_override); + if (reason == CPP_W_WARNING_DIRECTIVE) + diagnostic_override_option_index (&diagnostic, OPT_Wcpp); ret = report_diagnostic (&diagnostic); if (level == CPP_DL_WARNING_SYSHDR) - warn_system_headers = save_warn_system_headers; + global_dc->warn_system_headers = save_warn_system_headers; return ret; } @@ -1090,5 +1193,3 @@ dump_queued_macros (cpp_reader *pfile ATTRIBUTE_UNUSED) } cpp_undefine_queue = NULL; } - - diff --git a/gcc/fortran/cpp.h b/gcc/fortran/cpp.h index 54a899f6a8e..fa4383aefeb 100644 --- a/gcc/fortran/cpp.h +++ b/gcc/fortran/cpp.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2008 Free Software Foundation, Inc. +/* Copyright (C) 2008, 2010 Free Software Foundation, Inc. This file is part of GCC. @@ -24,13 +24,20 @@ bool gfc_cpp_enabled (void); bool gfc_cpp_preprocess_only (void); +bool gfc_cpp_makedep (void); + +void gfc_cpp_add_dep (const char *name, bool system); + +void gfc_cpp_add_target (const char *name); + const char *gfc_cpp_temporary_file (void); void gfc_cpp_init_0 (void); void gfc_cpp_init (void); -void gfc_cpp_init_options (unsigned int argc, const char **argv); +void gfc_cpp_init_options (unsigned int decoded_options_count, + struct cl_decoded_option *decoded_options); int gfc_cpp_handle_option(size_t scode, const char *arg, int value); diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c index 0d04d65aa29..b1cfd6ec75b 100644 --- a/gcc/fortran/data.c +++ b/gcc/fortran/data.c @@ -1,5 +1,5 @@ /* Supporting functions for resolving DATA statement. - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Lifang Zeng <zlf605@hotmail.com> @@ -34,8 +34,10 @@ along with GCC; see the file COPYING3. If not see trans-array.c. */ #include "config.h" +#include "system.h" #include "gfortran.h" #include "data.h" +#include "constructor.h" static void formalize_init_expr (gfc_expr *); @@ -76,67 +78,18 @@ get_array_index (gfc_array_ref *ar, mpz_t *offset) mpz_clear (tmp); } - -/* Find if there is a constructor which offset is equal to OFFSET. */ +/* Find if there is a constructor which component is equal to COM. + TODO: remove this, use symbol.c(gfc_find_component) instead. */ static gfc_constructor * -find_con_by_offset (splay_tree spt, mpz_t offset) +find_con_by_component (gfc_component *com, gfc_constructor_base base) { - mpz_t tmp; - gfc_constructor *ret = NULL; - gfc_constructor *con; - splay_tree_node sptn; - - /* The complexity is due to needing quick access to the linked list of - constructors. Both a linked list and a splay tree are used, and both - are kept up to date if they are array elements (which is the only time - that a specific constructor has to be found). */ - - gcc_assert (spt != NULL); - mpz_init (tmp); - - sptn = splay_tree_lookup (spt, (splay_tree_key) mpz_get_si (offset)); - - if (sptn) - ret = (gfc_constructor*) sptn->value; - else - { - /* Need to check and see if we match a range, so we will pull - the next lowest index and see if the range matches. */ - sptn = splay_tree_predecessor (spt, - (splay_tree_key) mpz_get_si (offset)); - if (sptn) - { - con = (gfc_constructor*) sptn->value; - if (mpz_cmp_ui (con->repeat, 1) > 0) - { - mpz_init (tmp); - mpz_add (tmp, con->n.offset, con->repeat); - if (mpz_cmp (offset, tmp) < 0) - ret = con; - mpz_clear (tmp); - } - else - ret = NULL; /* The range did not match. */ - } - else - ret = NULL; /* No pred, so no match. */ - } - - return ret; -} - + gfc_constructor *c; -/* Find if there is a constructor which component is equal to COM. */ + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + if (com == c->n.component) + return c; -static gfc_constructor * -find_con_by_component (gfc_component *com, gfc_constructor *con) -{ - for (; con; con = con->next) - { - if (com == con->n.component) - return con; - } return NULL; } @@ -147,8 +100,8 @@ find_con_by_component (gfc_component *com, gfc_constructor *con) according to normal assignment rules. */ static gfc_expr * -create_character_intializer (gfc_expr *init, gfc_typespec *ts, - gfc_ref *ref, gfc_expr *rvalue) +create_character_initializer (gfc_expr *init, gfc_typespec *ts, + gfc_ref *ref, gfc_expr *rvalue) { int len, start, end; gfc_char_t *dest; @@ -158,20 +111,11 @@ create_character_intializer (gfc_expr *init, gfc_typespec *ts, if (init == NULL) { /* Create a new initializer. */ - init = gfc_get_expr (); - init->expr_type = EXPR_CONSTANT; + init = gfc_get_character_expr (ts->kind, NULL, NULL, len); init->ts = *ts; - - dest = gfc_get_wide_string (len + 1); - dest[len] = '\0'; - init->value.character.length = len; - init->value.character.string = dest; - /* Blank the string if we're only setting a substring. */ - if (ref != NULL) - gfc_wide_memset (dest, ' ', len); } - else - dest = init->value.character.string; + + dest = init->value.character.string; if (ref) { @@ -205,15 +149,16 @@ create_character_intializer (gfc_expr *init, gfc_typespec *ts, /* Copy the initial value. */ if (rvalue->ts.type == BT_HOLLERITH) - len = rvalue->representation.length; + len = rvalue->representation.length - rvalue->ts.u.pad; else len = rvalue->value.character.length; if (len > end - start) { + gfc_warning_now ("Initialization string starting at %L was " + "truncated to fit the variable (%d/%d)", + &rvalue->where, end - start, len); len = end - start; - gfc_warning_now ("initialization string truncated to match variable " - "at %L", &rvalue->where); } if (rvalue->ts.type == BT_HOLLERITH) @@ -254,12 +199,9 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) gfc_expr *expr; gfc_constructor *con; gfc_constructor *last_con; - gfc_constructor *pred; gfc_symbol *symbol; gfc_typespec *last_ts; mpz_t offset; - splay_tree spt; - splay_tree_node sptn; symbol = lvalue->symtree->n.sym; init = symbol->value; @@ -289,12 +231,20 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) switch (ref->type) { case REF_ARRAY: + if (ref->u.ar.as->rank == 0) + { + gcc_assert (ref->u.ar.as->corank > 0); + if (init == NULL) + gfc_free (expr); + continue; + } + if (init && expr->expr_type != EXPR_ARRAY) { gfc_error ("'%s' at %L already is initialized at %L", lvalue->symtree->n.sym->name, &lvalue->where, &init->where); - return FAILURE; + goto abort; } if (init == NULL) @@ -317,7 +267,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) { gfc_error ("Data element below array lower bound at %L", &lvalue->where); - return FAILURE; + goto abort; } else { @@ -325,50 +275,23 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) if (spec_size (ref->u.ar.as, &size) == SUCCESS) { if (mpz_cmp (offset, size) >= 0) - { - mpz_clear (size); - gfc_error ("Data element above array upper bound at %L", - &lvalue->where); - return FAILURE; - } + { + mpz_clear (size); + gfc_error ("Data element above array upper bound at %L", + &lvalue->where); + goto abort; + } mpz_clear (size); } } - /* Splay tree containing offset and gfc_constructor. */ - spt = expr->con_by_offset; - - if (spt == NULL) + con = gfc_constructor_lookup (expr->value.constructor, + mpz_get_si (offset)); + if (!con) { - spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL); - expr->con_by_offset = spt; - con = NULL; - } - else - con = find_con_by_offset (spt, offset); - - if (con == NULL) - { - splay_tree_key j; - - /* Create a new constructor. */ - con = gfc_get_constructor (); - mpz_set (con->n.offset, offset); - j = (splay_tree_key) mpz_get_si (offset); - sptn = splay_tree_insert (spt, j, (splay_tree_value) con); - /* Fix up the linked list. */ - sptn = splay_tree_predecessor (spt, j); - if (sptn == NULL) - { /* Insert at the head. */ - con->next = expr->value.constructor; - expr->value.constructor = con; - } - else - { /* Insert in the chain. */ - pred = (gfc_constructor*) sptn->value; - con->next = pred->next; - pred->next = con; - } + con = gfc_constructor_insert_expr (&expr->value.constructor, + NULL, &rvalue->where, + mpz_get_si (offset)); } break; @@ -385,16 +308,15 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) last_ts = &ref->u.c.component->ts; /* Find the same element in the existing constructor. */ - con = expr->value.constructor; - con = find_con_by_component (ref->u.c.component, con); + con = find_con_by_component (ref->u.c.component, + expr->value.constructor); if (con == NULL) { /* Create a new constructor. */ - con = gfc_get_constructor (); + con = gfc_constructor_append_expr (&expr->value.constructor, + NULL, NULL); con->n.component = ref->u.c.component; - con->next = expr->value.constructor; - expr->value.constructor = con; } break; @@ -414,11 +336,13 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) last_con = con; } + mpz_clear (offset); + if (ref || last_ts->type == BT_CHARACTER) { if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL)) return FAILURE; - expr = create_character_intializer (init, last_ts, ref, rvalue); + expr = create_character_initializer (init, last_ts, ref, rvalue); } else { @@ -432,8 +356,10 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) expr = (LOCATION_LINE (init->where.lb->location) > LOCATION_LINE (rvalue->where.lb->location)) ? init : rvalue; - gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization " - "of '%s' at %L", symbol->name, &expr->where); + if (gfc_notify_std (GFC_STD_GNU,"Extension: " + "re-initialization of '%s' at %L", + symbol->name, &expr->where) == FAILURE) + return FAILURE; } expr = gfc_copy_expr (rvalue); @@ -447,186 +373,43 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) last_con->expr = expr; return SUCCESS; + +abort: + mpz_clear (offset); + return FAILURE; } /* Similarly, but initialize REPEAT consecutive values in LVALUE the same - value in RVALUE. For the nonce, LVALUE must refer to a full array, not - an array section. */ + value in RVALUE. */ -void +gfc_try gfc_assign_data_value_range (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index, mpz_t repeat) { - gfc_ref *ref; - gfc_expr *init, *expr; - gfc_constructor *con, *last_con; - gfc_constructor *pred; - gfc_symbol *symbol; - gfc_typespec *last_ts; - mpz_t offset; - splay_tree spt; - splay_tree_node sptn; - - symbol = lvalue->symtree->n.sym; - init = symbol->value; - last_ts = &symbol->ts; - last_con = NULL; - mpz_init_set_si (offset, 0); - - /* Find/create the parent expressions for subobject references. */ - for (ref = lvalue->ref; ref; ref = ref->next) - { - /* Use the existing initializer expression if it exists. - Otherwise create a new one. */ - if (init == NULL) - expr = gfc_get_expr (); - else - expr = init; - - /* Find or create this element. */ - switch (ref->type) - { - case REF_ARRAY: - if (init == NULL) - { - /* The element typespec will be the same as the array - typespec. */ - expr->ts = *last_ts; - /* Setup the expression to hold the constructor. */ - expr->expr_type = EXPR_ARRAY; - expr->rank = ref->u.ar.as->rank; - } - else - gcc_assert (expr->expr_type == EXPR_ARRAY); - - if (ref->u.ar.type == AR_ELEMENT) - { - get_array_index (&ref->u.ar, &offset); - - /* This had better not be the bottom of the reference. - We can still get to a full array via a component. */ - gcc_assert (ref->next != NULL); - } - else - { - mpz_set (offset, index); - - /* We're at a full array or an array section. This means - that we've better have found a full array, and that we're - at the bottom of the reference. */ - gcc_assert (ref->u.ar.type == AR_FULL); - gcc_assert (ref->next == NULL); - } - - /* Find the same element in the existing constructor. */ - - /* Splay tree containing offset and gfc_constructor. */ - spt = expr->con_by_offset; - - if (spt == NULL) - { - spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL); - expr->con_by_offset = spt; - con = NULL; - } - else - con = find_con_by_offset (spt, offset); - - if (con == NULL) - { - splay_tree_key j; - /* Create a new constructor. */ - con = gfc_get_constructor (); - mpz_set (con->n.offset, offset); - j = (splay_tree_key) mpz_get_si (offset); - - if (ref->next == NULL) - mpz_set (con->repeat, repeat); - sptn = splay_tree_insert (spt, j, (splay_tree_value) con); - /* Fix up the linked list. */ - sptn = splay_tree_predecessor (spt, j); - if (sptn == NULL) - { /* Insert at the head. */ - con->next = expr->value.constructor; - expr->value.constructor = con; - } - else - { /* Insert in the chain. */ - pred = (gfc_constructor*) sptn->value; - con->next = pred->next; - pred->next = con; - } - } - else - gcc_assert (ref->next != NULL); - break; - - case REF_COMPONENT: - if (init == NULL) - { - /* Setup the expression to hold the constructor. */ - expr->expr_type = EXPR_STRUCTURE; - expr->ts.type = BT_DERIVED; - expr->ts.u.derived = ref->u.c.sym; - } - else - gcc_assert (expr->expr_type == EXPR_STRUCTURE); - last_ts = &ref->u.c.component->ts; - - /* Find the same element in the existing constructor. */ - con = expr->value.constructor; - con = find_con_by_component (ref->u.c.component, con); - - if (con == NULL) - { - /* Create a new constructor. */ - con = gfc_get_constructor (); - con->n.component = ref->u.c.component; - con->next = expr->value.constructor; - expr->value.constructor = con; - } - - /* Since we're only intending to initialize arrays here, - there better be an inner reference. */ - gcc_assert (ref->next != NULL); - break; - - case REF_SUBSTRING: - default: - gcc_unreachable (); - } - - if (init == NULL) - { - /* Point the container at the new expression. */ - if (last_con == NULL) - symbol->value = expr; - else - last_con->expr = expr; - } - init = con->expr; - last_con = con; - } - - if (last_ts->type == BT_CHARACTER) - expr = create_character_intializer (init, last_ts, NULL, rvalue); - else - { - /* We should never be overwriting an existing initializer. */ - gcc_assert (!init); + mpz_t offset, last_offset; + gfc_try t; + + mpz_init (offset); + mpz_init (last_offset); + mpz_add (last_offset, index, repeat); + + t = SUCCESS; + for (mpz_set(offset, index) ; mpz_cmp(offset, last_offset) < 0; + mpz_add_ui (offset, offset, 1)) + if (gfc_assign_data_value (lvalue, rvalue, offset) == FAILURE) + { + t = FAILURE; + break; + } - expr = gfc_copy_expr (rvalue); - if (!gfc_compare_types (&lvalue->ts, &expr->ts)) - gfc_convert_type (expr, &lvalue->ts, 0); - } + mpz_clear (offset); + mpz_clear (last_offset); - if (last_con == NULL) - symbol->value = expr; - else - last_con->expr = expr; + return t; } + /* Modify the index of array section and re-calculate the array offset. */ void @@ -701,59 +484,30 @@ gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar, static void formalize_structure_cons (gfc_expr *expr) { - gfc_constructor *head; - gfc_constructor *tail; + gfc_constructor_base base = NULL; gfc_constructor *cur; - gfc_constructor *last; - gfc_constructor *c; gfc_component *order; - c = expr->value.constructor; - /* Constructor is already formalized. */ - if (!c || c->n.component == NULL) + cur = gfc_constructor_first (expr->value.constructor); + if (!cur || cur->n.component == NULL) return; - head = tail = NULL; for (order = expr->ts.u.derived->components; order; order = order->next) { - /* Find the next component. */ - last = NULL; - cur = c; - while (cur != NULL && cur->n.component != order) - { - last = cur; - cur = cur->next; - } - - if (cur == NULL) - { - /* Create a new one. */ - cur = gfc_get_constructor (); - } + cur = find_con_by_component (order, expr->value.constructor); + if (cur) + gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where); else - { - /* Remove it from the chain. */ - if (last == NULL) - c = cur->next; - else - last->next = cur->next; - cur->next = NULL; + gfc_constructor_append_expr (&base, NULL, NULL); + } - formalize_init_expr (cur->expr); - } + /* For all what it's worth, one would expect + gfc_constructor_free (expr->value.constructor); + here. However, if the constructor is actually free'd, + hell breaks loose in the testsuite?! */ - /* Add it to the new constructor. */ - if (head == NULL) - head = tail = cur; - else - { - tail->next = cur; - tail = tail->next; - } - } - gcc_assert (c == NULL); - expr->value.constructor = head; + expr->value.constructor = base; } @@ -773,13 +527,11 @@ formalize_init_expr (gfc_expr *expr) switch (type) { case EXPR_ARRAY: - c = expr->value.constructor; - while (c) - { - formalize_init_expr (c->expr); - c = c->next; - } - break; + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) + formalize_init_expr (c->expr); + + break; case EXPR_STRUCTURE: formalize_structure_cons (expr); diff --git a/gcc/fortran/data.h b/gcc/fortran/data.h index 0d31a920e6d..c54c75de9c0 100644 --- a/gcc/fortran/data.h +++ b/gcc/fortran/data.h @@ -20,5 +20,5 @@ along with GCC; see the file COPYING3. If not see void gfc_formalize_init_value (gfc_symbol *); void gfc_get_section_index (gfc_array_ref *, mpz_t *, mpz_t *); gfc_try gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t); -void gfc_assign_data_value_range (gfc_expr *, gfc_expr *, mpz_t, mpz_t); +gfc_try gfc_assign_data_value_range (gfc_expr *, gfc_expr *, mpz_t, mpz_t); void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *); diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 923750388af..5b4ab182ed7 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -25,7 +25,7 @@ along with GCC; see the file COPYING3. If not see #include "match.h" #include "parse.h" #include "flags.h" - +#include "constructor.h" /* Macros to access allocate memory for gfc_data_variable, gfc_data_value and gfc_data. */ @@ -134,6 +134,7 @@ free_value (gfc_data_value *p) for (; p; p = q) { q = p->next; + mpz_clear (p->repeat); gfc_free_expr (p->expr); gfc_free (p); } @@ -570,6 +571,62 @@ cleanup: /************************ Declaration statements *********************/ + +/* Auxilliary function to merge DIMENSION and CODIMENSION array specs. */ + +static void +merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy) +{ + int i; + + if (to->rank == 0 && from->rank > 0) + { + to->rank = from->rank; + to->type = from->type; + to->cray_pointee = from->cray_pointee; + to->cp_was_assumed = from->cp_was_assumed; + + for (i = 0; i < to->corank; i++) + { + to->lower[from->rank + i] = to->lower[i]; + to->upper[from->rank + i] = to->upper[i]; + } + for (i = 0; i < from->rank; i++) + { + if (copy) + { + to->lower[i] = gfc_copy_expr (from->lower[i]); + to->upper[i] = gfc_copy_expr (from->upper[i]); + } + else + { + to->lower[i] = from->lower[i]; + to->upper[i] = from->upper[i]; + } + } + } + else if (to->corank == 0 && from->corank > 0) + { + to->corank = from->corank; + to->cotype = from->cotype; + + for (i = 0; i < from->corank; i++) + { + if (copy) + { + to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]); + to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]); + } + else + { + to->lower[to->rank + i] = from->lower[i]; + to->upper[to->rank + i] = from->upper[i]; + } + } + } +} + + /* Match an intent specification. Since this can only happen after an INTENT word, a legal intent-spec must follow. */ @@ -658,7 +715,7 @@ match_char_length (gfc_expr **expr) if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: " "Old-style character length at %C") == FAILURE) return MATCH_ERROR; - *expr = gfc_int_expr (length); + *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, length); return m; } @@ -934,7 +991,7 @@ verify_c_interop_param (gfc_symbol *sym) /* Make personalized messages to give better feedback. */ if (sym->ts.type == BT_DERIVED) gfc_error ("Type '%s' at %L is a parameter to the BIND(C) " - " procedure '%s' but is not C interoperable " + "procedure '%s' but is not C interoperable " "because derived type '%s' is not C interoperable", sym->name, &(sym->declared_at), sym->ns->proc_name->name, @@ -1057,6 +1114,7 @@ build_sym (const char *name, gfc_charlen *cl, dimension attribute. */ attr = current_attr; attr.dimension = 0; + attr.codimension = 0; if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE) return FAILURE; @@ -1098,13 +1156,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); - } + 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; } @@ -1257,9 +1312,10 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) } /* Check if the assignment can happen. This has to be put off - until later for a derived type variable. */ + until later for derived type variables and procedure pointers. */ if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS + && !sym->attr.proc_pointer && gfc_check_assign_symbol (sym, init) == FAILURE) return FAILURE; @@ -1282,13 +1338,18 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) if (init->expr_type == EXPR_CONSTANT) { clen = init->value.character.length; - sym->ts.u.cl->length = gfc_int_expr (clen); + sym->ts.u.cl->length + = gfc_get_int_expr (gfc_default_integer_kind, + NULL, clen); } else if (init->expr_type == EXPR_ARRAY) { - gfc_expr *p = init->value.constructor->expr; - clen = p->value.character.length; - sym->ts.u.cl->length = gfc_int_expr (clen); + gfc_constructor *c; + c = gfc_constructor_first (init->value.constructor); + clen = c->expr->value.character.length; + sym->ts.u.cl->length + = gfc_get_int_expr (gfc_default_integer_kind, + NULL, clen); } else if (init->ts.u.cl && init->ts.u.cl->length) sym->ts.u.cl->length = @@ -1299,23 +1360,70 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) { int len = mpz_get_si (sym->ts.u.cl->length->value.integer); - gfc_constructor * p; if (init->expr_type == EXPR_CONSTANT) gfc_set_constant_character_len (len, init, -1); else if (init->expr_type == EXPR_ARRAY) { + gfc_constructor *c; + /* Build a new charlen to prevent simplification from deleting the length before it is resolved. */ init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length); - for (p = init->value.constructor; p; p = p->next) - gfc_set_constant_character_len (len, p->expr, -1); + for (c = gfc_constructor_first (init->value.constructor); + c; c = gfc_constructor_next (c)) + gfc_set_constant_character_len (len, c->expr, -1); } } } + /* If sym is implied-shape, set its upper bounds from init. */ + if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension + && sym->as->type == AS_IMPLIED_SHAPE) + { + int dim; + + if (init->rank == 0) + { + gfc_error ("Can't initialize implied-shape array at %L" + " with scalar", &sym->declared_at); + return FAILURE; + } + gcc_assert (sym->as->rank == init->rank); + + /* Shape should be present, we get an initialization expression. */ + gcc_assert (init->shape); + + for (dim = 0; dim < sym->as->rank; ++dim) + { + int k; + gfc_expr* lower; + gfc_expr* e; + + lower = sym->as->lower[dim]; + if (lower->expr_type != EXPR_CONSTANT) + { + gfc_error ("Non-constant lower bound in implied-shape" + " declaration at %L", &lower->where); + return FAILURE; + } + + /* All dimensions must be without upper bound. */ + gcc_assert (!sym->as->upper[dim]); + + k = lower->ts.kind; + e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at); + mpz_add (e->value.integer, + lower->value.integer, init->shape[dim]); + mpz_sub_ui (e->value.integer, e->value.integer, 1); + sym->as->upper[dim] = e; + } + + sym->as->type = AS_EXPLICIT; + } + /* Need to check if the expression we initialized this to was one of the iso_c_binding named constants. If so, and we're a parameter (constant), let it be iso_c. @@ -1335,38 +1443,27 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) if (init->ts.is_iso_c) sym->ts.f90_type = init->ts.f90_type; } - + /* Add initializer. Make sure we keep the ranks sane. */ if (sym->attr.dimension && init->rank == 0) { mpz_t size; gfc_expr *array; - gfc_constructor *c; int n; if (sym->attr.flavor == FL_PARAMETER && init->expr_type == EXPR_CONSTANT && spec_size (sym->as, &size) == SUCCESS && mpz_cmp_si (size, 0) > 0) { - array = gfc_start_constructor (init->ts.type, init->ts.kind, - &init->where); - - array->value.constructor = c = NULL; + array = gfc_get_array_expr (init->ts.type, init->ts.kind, + &init->where); for (n = 0; n < (int)mpz_get_si (size); n++) - { - if (array->value.constructor == NULL) - { - array->value.constructor = c = gfc_get_constructor (); - c->expr = init; - } - else - { - c->next = gfc_get_constructor (); - c = c->next; - c->expr = gfc_copy_expr (init); - } - } - + gfc_constructor_append_expr (&array->value.constructor, + n == 0 + ? init + : gfc_copy_expr (init), + &init->where); + array->shape = gfc_get_shape (sym->as->rank); for (n = 0; n < sym->as->rank; n++) spec_dimen_size (sym->as, n, &array->shape[n]); @@ -1430,7 +1527,12 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, c->as = *as; if (c->as != NULL) - c->attr.dimension = 1; + { + if (c->as->corank) + c->attr.codimension = 1; + if (c->as->rank) + c->attr.dimension = 1; + } *as = NULL; /* Should this ever get more complicated, combine with similar section @@ -1451,15 +1553,14 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, else if (mpz_cmp (c->ts.u.cl->length->value.integer, c->initializer->ts.u.cl->length->value.integer)) { - bool has_ts; - gfc_constructor *ctor = c->initializer->value.constructor; - - has_ts = (c->initializer->ts.u.cl - && c->initializer->ts.u.cl->length_from_typespec); + gfc_constructor *ctor; + ctor = gfc_constructor_first (c->initializer->value.constructor); if (ctor) { int first_len; + bool has_ts = (c->initializer->ts.u.cl + && c->initializer->ts.u.cl->length_from_typespec); /* Remember the length of the first element for checking that all elements *in the constructor* have the same @@ -1468,11 +1569,12 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, gcc_assert (ctor->expr->ts.type == BT_CHARACTER); first_len = ctor->expr->value.character.length; - for (; ctor; ctor = ctor->next) + for ( ; ctor; ctor = gfc_constructor_next (ctor)) + if (ctor->expr->expr_type == EXPR_CONSTANT) { - if (ctor->expr->expr_type == EXPR_CONSTANT) - gfc_set_constant_character_len (len, ctor->expr, - has_ts ? -1 : first_len); + gfc_set_constant_character_len (len, ctor->expr, + has_ts ? -1 : first_len); + ctor->expr->ts.u.cl->length = gfc_copy_expr (c->ts.u.cl->length); } } } @@ -1512,7 +1614,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, scalar: if (c->ts.type == BT_CLASS) - gfc_build_class_symbol (&c->ts, &c->attr, &c->as); + gfc_build_class_symbol (&c->ts, &c->attr, &c->as, true); return t; } @@ -1524,7 +1626,6 @@ match gfc_match_null (gfc_expr **result) { gfc_symbol *sym; - gfc_expr *e; match m; m = gfc_match (" null ( )"); @@ -1546,12 +1647,49 @@ gfc_match_null (gfc_expr **result) || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)) return MATCH_ERROR; - e = gfc_get_expr (); - e->where = gfc_current_locus; - e->expr_type = EXPR_NULL; - e->ts.type = BT_UNKNOWN; + *result = gfc_get_null_expr (&gfc_current_locus); + + return MATCH_YES; +} + + +/* Match the initialization expr for a data pointer or procedure pointer. */ + +static match +match_pointer_init (gfc_expr **init, int procptr) +{ + match m; + + if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED) + { + gfc_error ("Initialization of pointer at %C is not allowed in " + "a PURE procedure"); + return MATCH_ERROR; + } + + /* Match NULL() initilization. */ + m = gfc_match_null (init); + if (m != MATCH_NO) + return m; + + /* Match non-NULL initialization. */ + gfc_matching_procptr_assignment = procptr; + m = gfc_match_rvalue (init); + gfc_matching_procptr_assignment = 0; + if (m == MATCH_ERROR) + return MATCH_ERROR; + else if (m == MATCH_NO) + { + gfc_error ("Error in pointer initialization at %C"); + return MATCH_ERROR; + } - *result = e; + if (!procptr) + gfc_resolve_expr (*init); + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: non-NULL pointer " + "initialization at %C") == FAILURE) + return MATCH_ERROR; return MATCH_YES; } @@ -1589,7 +1727,7 @@ variable_decl (int elem) var_locus = gfc_current_locus; /* Now we could see the optional array spec. or character length. */ - m = gfc_match_array_spec (&as); + m = gfc_match_array_spec (&as, true, true); if (gfc_option.flag_cray_pointer && m == MATCH_YES) cp_as = gfc_copy_array_spec (as); else if (m == MATCH_ERROR) @@ -1597,6 +1735,36 @@ variable_decl (int elem) if (m == MATCH_NO) as = gfc_copy_array_spec (current_as); + else if (current_as) + merge_array_spec (current_as, as, true); + + /* At this point, we know for sure if the symbol is PARAMETER and can thus + determine (and check) whether it can be implied-shape. If it + was parsed as assumed-size, change it because PARAMETERs can not + be assumed-size. */ + if (as) + { + if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER) + { + m = MATCH_ERROR; + gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape", + name, &var_locus); + goto cleanup; + } + + if (as->type == AS_ASSUMED_SIZE && as->rank == 1 + && current_attr.flavor == FL_PARAMETER) + as->type = AS_IMPLIED_SHAPE; + + if (as->type == AS_IMPLIED_SHAPE + && gfc_notify_std (GFC_STD_F2008, + "Fortran 2008: Implied-shape array at %L", + &var_locus) == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } + } char_len = NULL; cl = NULL; @@ -1710,7 +1878,7 @@ variable_decl (int elem) specified in the procedure definition, except that the interface may specify a procedure that is not pure if the procedure is defined to be pure(12.3.2). */ - if (current_ts.type == BT_DERIVED + if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) && gfc_current_ns->proc_name && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY && current_ts.u.derived->ns != gfc_current_ns) @@ -1774,23 +1942,9 @@ variable_decl (int elem) goto cleanup; } - m = gfc_match_null (&initializer); - if (m == MATCH_NO) - { - gfc_error ("Pointer initialization requires a NULL() at %C"); - m = MATCH_ERROR; - } - - if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED) - { - gfc_error ("Initialization of pointer at %C is not allowed in " - "a PURE procedure"); - m = MATCH_ERROR; - } - + m = match_pointer_init (&initializer, 0); if (m != MATCH_YES) goto cleanup; - } else if (gfc_match_char ('=') == MATCH_YES) { @@ -2245,7 +2399,7 @@ done: cl = gfc_new_charlen (gfc_current_ns, NULL); if (seen_length == 0) - cl->length = gfc_int_expr (1); + cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); else cl->length = len; @@ -2288,7 +2442,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) gfc_symbol *sym; match m; char c; - bool seen_deferred_kind; + bool seen_deferred_kind, matched_type; /* A belt and braces check that the typespec is correctly being treated as a deferred characteristic association. */ @@ -2320,47 +2474,88 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return MATCH_YES; } - if (gfc_match (" integer") == MATCH_YES) + + m = gfc_match (" type ( %n", name); + matched_type = (m == MATCH_YES); + + if ((matched_type && strcmp ("integer", name) == 0) + || (!matched_type && gfc_match (" integer") == MATCH_YES)) { ts->type = BT_INTEGER; ts->kind = gfc_default_integer_kind; goto get_kind; } - if (gfc_match (" character") == MATCH_YES) + if ((matched_type && strcmp ("character", name) == 0) + || (!matched_type && gfc_match (" character") == MATCH_YES)) { + if (matched_type + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with " + "intrinsic-type-spec at %C") == FAILURE) + return MATCH_ERROR; + ts->type = BT_CHARACTER; if (implicit_flag == 0) - return gfc_match_char_spec (ts); + m = gfc_match_char_spec (ts); else - return MATCH_YES; + m = MATCH_YES; + + if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES) + m = MATCH_ERROR; + + return m; } - if (gfc_match (" real") == MATCH_YES) + if ((matched_type && strcmp ("real", name) == 0) + || (!matched_type && gfc_match (" real") == MATCH_YES)) { ts->type = BT_REAL; ts->kind = gfc_default_real_kind; goto get_kind; } - if (gfc_match (" double precision") == MATCH_YES) + if ((matched_type + && (strcmp ("doubleprecision", name) == 0 + || (strcmp ("double", name) == 0 + && gfc_match (" precision") == MATCH_YES))) + || (!matched_type && gfc_match (" double precision") == MATCH_YES)) { + if (matched_type + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with " + "intrinsic-type-spec at %C") == FAILURE) + return MATCH_ERROR; + if (matched_type && gfc_match_char (')') != MATCH_YES) + return MATCH_ERROR; + ts->type = BT_REAL; ts->kind = gfc_default_double_kind; return MATCH_YES; } - if (gfc_match (" complex") == MATCH_YES) + if ((matched_type && strcmp ("complex", name) == 0) + || (!matched_type && gfc_match (" complex") == MATCH_YES)) { ts->type = BT_COMPLEX; ts->kind = gfc_default_complex_kind; goto get_kind; } - if (gfc_match (" double complex") == MATCH_YES) + if ((matched_type + && (strcmp ("doublecomplex", name) == 0 + || (strcmp ("double", name) == 0 + && gfc_match (" complex") == MATCH_YES))) + || (!matched_type && gfc_match (" double complex") == MATCH_YES)) { - if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not " - "conform to the Fortran 95 standard") == FAILURE) + if (gfc_notify_std (GFC_STD_GNU, "Extension: DOUBLE COMPLEX at %C") + == FAILURE) + return MATCH_ERROR; + + if (matched_type + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with " + "intrinsic-type-spec at %C") == FAILURE) + return MATCH_ERROR; + + if (matched_type && gfc_match_char (')') != MATCH_YES) return MATCH_ERROR; ts->type = BT_COMPLEX; @@ -2368,14 +2563,17 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return MATCH_YES; } - if (gfc_match (" logical") == MATCH_YES) + if ((matched_type && strcmp ("logical", name) == 0) + || (!matched_type && gfc_match (" logical") == MATCH_YES)) { ts->type = BT_LOGICAL; ts->kind = gfc_default_logical_kind; goto get_kind; } - m = gfc_match (" type ( %n )", name); + if (matched_type) + m = gfc_match_char (')'); + if (m == MATCH_YES) ts->type = BT_DERIVED; else @@ -2436,23 +2634,43 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return MATCH_YES; get_kind: + if (matched_type + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with " + "intrinsic-type-spec at %C") == FAILURE) + return MATCH_ERROR; + /* For all types except double, derived and character, look for an optional kind specifier. MATCH_NO is actually OK at this point. */ if (implicit_flag == 1) - return MATCH_YES; + { + if (matched_type && gfc_match_char (')') != MATCH_YES) + return MATCH_ERROR; + + return MATCH_YES; + } if (gfc_current_form == FORM_FREE) { c = gfc_peek_ascii_char (); if (!gfc_is_whitespace (c) && c != '*' && c != '(' && c != ':' && c != ',') - return MATCH_NO; + { + if (matched_type && c == ')') + { + gfc_next_ascii_char (); + return MATCH_YES; + } + return MATCH_NO; + } } m = gfc_match_kind_spec (ts, false); if (m == MATCH_NO && ts->type != BT_CHARACTER) m = gfc_match_old_kind_spec (ts); + if (matched_type && gfc_match_char (')') != MATCH_YES) + return MATCH_ERROR; + /* Defer association of the KIND expression of function results until after USE and IMPORT statements. */ if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ()) @@ -2626,7 +2844,8 @@ gfc_match_implicit (void) { ts.kind = gfc_default_character_kind; ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - ts.u.cl->length = gfc_int_expr (1); + ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1); } /* Record the Successful match. */ @@ -2820,8 +3039,8 @@ match_attr_spec (void) DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL, DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE, - DECL_IS_BIND_C, DECL_ASYNCHRONOUS, DECL_NONE, - GFC_DECL_END /* Sentinel */ + DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS, + DECL_NONE, GFC_DECL_END /* Sentinel */ } decl_types; @@ -2884,6 +3103,7 @@ match_attr_spec (void) } break; } + break; case 'b': /* Try and match the bind(c). */ @@ -2894,6 +3114,27 @@ match_attr_spec (void) goto cleanup; break; + case 'c': + gfc_next_ascii_char (); + if ('o' != gfc_next_ascii_char ()) + break; + switch (gfc_next_ascii_char ()) + { + case 'd': + if (match_string_p ("imension")) + { + d = DECL_CODIMENSION; + break; + } + case 'n': + if (match_string_p ("tiguous")) + { + d = DECL_CONTIGUOUS; + break; + } + } + break; + case 'd': if (match_string_p ("dimension")) d = DECL_DIMENSION; @@ -3039,13 +3280,27 @@ match_attr_spec (void) seen[d]++; seen_at[d] = gfc_current_locus; - if (d == DECL_DIMENSION) + if (d == DECL_DIMENSION || d == DECL_CODIMENSION) { - m = gfc_match_array_spec (¤t_as); + gfc_array_spec *as = NULL; + + m = gfc_match_array_spec (&as, d == DECL_DIMENSION, + d == DECL_CODIMENSION); + + if (current_as == NULL) + current_as = as; + else if (m == MATCH_YES) + { + merge_array_spec (as, current_as, false); + gfc_free (as); + } if (m == MATCH_NO) { - gfc_error ("Missing dimension specification at %C"); + if (d == DECL_CODIMENSION) + gfc_error ("Missing codimension specification at %C"); + else + gfc_error ("Missing dimension specification at %C"); m = MATCH_ERROR; } @@ -3067,6 +3322,12 @@ match_attr_spec (void) case DECL_ASYNCHRONOUS: attr = "ASYNCHRONOUS"; break; + case DECL_CODIMENSION: + attr = "CODIMENSION"; + break; + case DECL_CONTIGUOUS: + attr = "CONTIGUOUS"; + break; case DECL_DIMENSION: attr = "DIMENSION"; break; @@ -3135,9 +3396,9 @@ match_attr_spec (void) continue; if (gfc_current_state () == COMP_DERIVED - && d != DECL_DIMENSION && d != DECL_POINTER - && d != DECL_PRIVATE && d != DECL_PUBLIC - && d != DECL_NONE) + && d != DECL_DIMENSION && d != DECL_CODIMENSION + && d != DECL_POINTER && d != DECL_PRIVATE + && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE) { if (d == DECL_ALLOCATABLE) { @@ -3202,6 +3463,19 @@ match_attr_spec (void) t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]); break; + case DECL_CODIMENSION: + t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]); + break; + + case DECL_CONTIGUOUS: + if (gfc_notify_std (GFC_STD_F2008, + "Fortran 2008: CONTIGUOUS attribute at %C") + == FAILURE) + t = FAILURE; + else + t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]); + break; + case DECL_DIMENSION: t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]); break; @@ -3266,7 +3540,7 @@ match_attr_spec (void) break; case DECL_SAVE: - t = gfc_add_save (¤t_attr, NULL, &seen_at[d]); + t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]); break; case DECL_TARGET: @@ -3306,6 +3580,10 @@ match_attr_spec (void) } } + /* Module variables implicitly have the SAVE attribute. */ + if (gfc_current_state () == COMP_MODULE && !current_attr.save) + current_attr.save = SAVE_IMPLICIT; + colon_seen = 1; return MATCH_YES; @@ -3367,7 +3645,8 @@ gfc_try verify_c_interop (gfc_typespec *ts) { if (ts->type == BT_DERIVED && ts->u.derived != NULL) - return (ts->u.derived->ts.is_c_interop ? SUCCESS : FAILURE); + return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c) + ? SUCCESS : FAILURE; else if (ts->is_c_interop != 1) return FAILURE; @@ -3807,45 +4086,81 @@ match gfc_match_prefix (gfc_typespec *ts) { bool seen_type; + bool seen_impure; + bool found_prefix; gfc_clear_attr (¤t_attr); - seen_type = 0; + seen_type = false; + seen_impure = false; gcc_assert (!gfc_matching_prefix); gfc_matching_prefix = true; -loop: - if (!seen_type && ts != NULL - && gfc_match_decl_type_spec (ts, 0) == MATCH_YES - && gfc_match_space () == MATCH_YES) + do { + found_prefix = false; - seen_type = 1; - goto loop; - } + if (!seen_type && ts != NULL + && gfc_match_decl_type_spec (ts, 0) == MATCH_YES + && gfc_match_space () == MATCH_YES) + { - if (gfc_match ("elemental% ") == MATCH_YES) - { - if (gfc_add_elemental (¤t_attr, NULL) == FAILURE) - goto error; + seen_type = true; + found_prefix = true; + } + + if (gfc_match ("elemental% ") == MATCH_YES) + { + if (gfc_add_elemental (¤t_attr, NULL) == FAILURE) + goto error; - goto loop; + found_prefix = true; + } + + if (gfc_match ("pure% ") == MATCH_YES) + { + if (gfc_add_pure (¤t_attr, NULL) == FAILURE) + goto error; + + found_prefix = true; + } + + if (gfc_match ("recursive% ") == MATCH_YES) + { + if (gfc_add_recursive (¤t_attr, NULL) == FAILURE) + goto error; + + found_prefix = true; + } + + /* IMPURE is a somewhat special case, as it needs not set an actual + attribute but rather only prevents ELEMENTAL routines from being + automatically PURE. */ + if (gfc_match ("impure% ") == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2008, + "Fortran 2008: IMPURE procedure at %C") + == FAILURE) + goto error; + + seen_impure = true; + found_prefix = true; + } } + while (found_prefix); - if (gfc_match ("pure% ") == MATCH_YES) + /* IMPURE and PURE must not both appear, of course. */ + if (seen_impure && current_attr.pure) { - if (gfc_add_pure (¤t_attr, NULL) == FAILURE) - goto error; - - goto loop; + gfc_error ("PURE and IMPURE must not appear both at %C"); + goto error; } - if (gfc_match ("recursive% ") == MATCH_YES) + /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */ + if (!seen_impure && current_attr.elemental && !current_attr.pure) { - if (gfc_add_recursive (¤t_attr, NULL) == FAILURE) + if (gfc_add_pure (¤t_attr, NULL) == FAILURE) goto error; - - goto loop; } /* At this point, the next item is not a prefix. */ @@ -4393,20 +4708,7 @@ match_procedure_decl (void) goto cleanup; } - m = gfc_match_null (&initializer); - if (m == MATCH_NO) - { - gfc_error ("Pointer initialization requires a NULL() at %C"); - m = MATCH_ERROR; - } - - if (gfc_pure (NULL)) - { - gfc_error ("Initialization of pointer at %C is not allowed in " - "a PURE procedure"); - m = MATCH_ERROR; - } - + m = match_pointer_init (&initializer, 1); if (m != MATCH_YES) goto cleanup; @@ -4533,18 +4835,7 @@ match_ppc_decl (void) if (gfc_match (" =>") == MATCH_YES) { - m = gfc_match_null (&initializer); - if (m == MATCH_NO) - { - gfc_error ("Pointer initialization requires a NULL() at %C"); - m = MATCH_ERROR; - } - if (gfc_pure (NULL)) - { - gfc_error ("Initialization of pointer at %C is not allowed in " - "a PURE procedure"); - m = MATCH_ERROR; - } + m = match_pointer_init (&initializer, 1); if (m != MATCH_YES) { gfc_free_expr (initializer); @@ -4853,6 +5144,10 @@ gfc_match_entry (void) if (m != MATCH_YES) return m; + if (gfc_notify_std (GFC_STD_F2008_OBS, "Fortran 2008 obsolescent feature: " + "ENTRY statement at %C") == FAILURE) + return MATCH_ERROR; + state = gfc_current_state (); if (state != COMP_SUBROUTINE && state != COMP_FUNCTION) { @@ -5402,14 +5697,23 @@ gfc_match_end (gfc_statement *st) block_name = gfc_current_block () == NULL ? NULL : gfc_current_block ()->name; - if (state == COMP_BLOCK && !strcmp (block_name, "block@")) - block_name = NULL; - - if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS) + switch (state) { + case COMP_ASSOCIATE: + case COMP_BLOCK: + if (!strcmp (block_name, "block@")) + block_name = NULL; + break; + + case COMP_CONTAINS: + case COMP_DERIVED_CONTAINS: state = gfc_state_stack->previous->state; block_name = gfc_state_stack->previous->sym == NULL ? NULL : gfc_state_stack->previous->sym->name; + break; + + default: + break; } switch (state) @@ -5458,6 +5762,12 @@ gfc_match_end (gfc_statement *st) eos_ok = 0; break; + case COMP_ASSOCIATE: + *st = ST_END_ASSOCIATE; + target = " associate"; + eos_ok = 0; + break; + case COMP_BLOCK: *st = ST_END_BLOCK; target = " block"; @@ -5517,7 +5827,14 @@ gfc_match_end (gfc_statement *st) if (gfc_match_eos () == MATCH_YES) { - if (!eos_ok) + if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION)) + { + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: END statement " + "instead of %s statement at %L", + gfc_ascii_statement (*st), &old_loc) == FAILURE) + goto cleanup; + } + else if (!eos_ok) { /* We would have required END [something]. */ gfc_error ("%s statement expected at %L", @@ -5541,7 +5858,7 @@ gfc_match_end (gfc_statement *st) if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK - && *st != ST_END_CRITICAL) + && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL) return MATCH_YES; if (!block_name) @@ -5626,11 +5943,15 @@ attr_decl1 (void) /* Deal with possible array specification for certain attributes. */ if (current_attr.dimension + || current_attr.codimension || current_attr.allocatable || current_attr.pointer || current_attr.target) { - m = gfc_match_array_spec (&as); + m = gfc_match_array_spec (&as, !current_attr.codimension, + !current_attr.dimension + && !current_attr.pointer + && !current_attr.target); if (m == MATCH_ERROR) goto cleanup; @@ -5650,6 +5971,14 @@ attr_decl1 (void) goto cleanup; } + if (current_attr.codimension && m == MATCH_NO) + { + gfc_error ("Missing array specification at %L in CODIMENSION " + "statement", &var_locus); + m = MATCH_ERROR; + goto cleanup; + } + if ((current_attr.allocatable || current_attr.pointer) && (m == MATCH_YES) && (as->type != AS_DEFERRED)) { @@ -5662,29 +5991,29 @@ 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 && sym->ts.u.derived) + if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class) { - gfc_component *comp; - comp = gfc_find_component (sym->ts.u.derived, "$data", true, true); - if (comp == NULL || gfc_copy_attr (&comp->attr, ¤t_attr, - &var_locus) == FAILURE) + if (gfc_copy_attr (&CLASS_DATA (sym)->attr, ¤t_attr,&var_locus) + == FAILURE) { m = MATCH_ERROR; goto cleanup; } - sym->attr.class_ok = (sym->attr.class_ok - || current_attr.allocatable - || current_attr.pointer); } else { - if (current_attr.dimension == 0 - && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE) + if (current_attr.dimension == 0 && current_attr.codimension == 0 + && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE) { m = MATCH_ERROR; 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) { @@ -5777,7 +6106,7 @@ static match cray_pointer_decl (void) { match m; - gfc_array_spec *as; + gfc_array_spec *as = NULL; gfc_symbol *cptr; /* Pointer symbol. */ gfc_symbol *cpte; /* Pointee symbol. */ locus var_locus; @@ -5846,7 +6175,7 @@ cray_pointer_decl (void) } /* Check for an optional array spec. */ - m = gfc_match_array_spec (&as); + m = gfc_match_array_spec (&as, true, false); if (m == MATCH_ERROR) { gfc_free_array_spec (as); @@ -6006,6 +6335,30 @@ gfc_match_allocatable (void) match +gfc_match_codimension (void) +{ + gfc_clear_attr (¤t_attr); + current_attr.codimension = 1; + + return attr_decl (); +} + + +match +gfc_match_contiguous (void) +{ + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTIGUOUS statement at %C") + == FAILURE) + return MATCH_ERROR; + + gfc_clear_attr (¤t_attr); + current_attr.contiguous = 1; + + return attr_decl (); +} + + +match gfc_match_dimension (void) { gfc_clear_attr (¤t_attr); @@ -6376,8 +6729,8 @@ gfc_match_save (void) switch (m) { case MATCH_YES: - if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus) - == FAILURE) + if (gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, + &gfc_current_locus) == FAILURE) return MATCH_ERROR; goto next_item; @@ -6493,11 +6846,19 @@ gfc_match_volatile (void) for(;;) { /* VOLATILE is special because it can be added to host-associated - symbols locally. */ + symbols locally. Except for coarrays. */ m = gfc_match_symbol (&sym, 1); switch (m) { case MATCH_YES: + /* F2008, C560+C561. VOLATILE for host-/use-associated variable or + for variable in a BLOCK which is defined outside of the BLOCK. */ + if (sym->ns != gfc_current_ns && sym->attr.codimension) + { + gfc_error ("Specifying VOLATILE for coarray variable '%s' at " + "%C, which is use-/host-associated", sym->name); + return MATCH_ERROR; + } if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus) == FAILURE) return MATCH_ERROR; @@ -7027,12 +7388,7 @@ static gfc_expr * enum_initializer (gfc_expr *last_initializer, locus where) { gfc_expr *result; - - result = gfc_get_expr (); - result->expr_type = EXPR_CONSTANT; - result->ts.type = BT_INTEGER; - result->ts.kind = gfc_c_int_kind; - result->where = where; + result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where); mpz_init (result->value.integer); @@ -7424,14 +7780,15 @@ match_procedure_in_type (void) { char name[GFC_MAX_SYMBOL_LEN + 1]; char target_buf[GFC_MAX_SYMBOL_LEN + 1]; - char* target = NULL; - gfc_typebound_proc* tb; + char* target = NULL, *ifc = NULL; + gfc_typebound_proc tb; bool seen_colons; bool seen_attrs; match m; gfc_symtree* stree; gfc_namespace* ns; gfc_symbol* block; + int num; /* Check current state. */ gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS); @@ -7456,28 +7813,26 @@ match_procedure_in_type (void) return MATCH_ERROR; } - target = target_buf; + ifc = target_buf; } /* Construct the data structure. */ - tb = gfc_get_typebound_proc (); - tb->where = gfc_current_locus; - tb->is_generic = 0; + memset (&tb, 0, sizeof (tb)); + tb.where = gfc_current_locus; /* Match binding attributes. */ - m = match_binding_attributes (tb, false, false); + m = match_binding_attributes (&tb, false, false); if (m == MATCH_ERROR) return m; seen_attrs = (m == MATCH_YES); - /* Check that attribute DEFERRED is given iff an interface is specified, which - means target != NULL. */ - if (tb->deferred && !target) + /* Check that attribute DEFERRED is given if an interface is specified. */ + if (tb.deferred && !ifc) { gfc_error ("Interface must be specified for DEFERRED binding at %C"); return MATCH_ERROR; } - if (target && !tb->deferred) + if (ifc && !tb.deferred) { gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED"); return MATCH_ERROR; @@ -7494,97 +7849,103 @@ match_procedure_in_type (void) return MATCH_ERROR; } - /* Match the binding name. */ - m = gfc_match_name (name); - if (m == MATCH_ERROR) - return m; - if (m == MATCH_NO) - { - gfc_error ("Expected binding name at %C"); - return MATCH_ERROR; - } - - /* Try to match the '=> target', if it's there. */ - m = gfc_match (" =>"); - if (m == MATCH_ERROR) - return m; - if (m == MATCH_YES) + /* Match the binding names. */ + for(num=1;;num++) { - if (tb->deferred) + m = gfc_match_name (name); + if (m == MATCH_ERROR) + return m; + if (m == MATCH_NO) { - gfc_error ("'=> target' is invalid for DEFERRED binding at %C"); + gfc_error ("Expected binding name at %C"); return MATCH_ERROR; } - if (!seen_colons) - { - gfc_error ("'::' needed in PROCEDURE binding with explicit target" - " at %C"); - return MATCH_ERROR; - } + if (num>1 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: PROCEDURE list" + " at %C") == FAILURE) + return MATCH_ERROR; - m = gfc_match_name (target_buf); + /* Try to match the '=> target', if it's there. */ + target = ifc; + m = gfc_match (" =>"); if (m == MATCH_ERROR) return m; - if (m == MATCH_NO) + if (m == MATCH_YES) { - gfc_error ("Expected binding target after '=>' at %C"); - return MATCH_ERROR; + if (tb.deferred) + { + gfc_error ("'=> target' is invalid for DEFERRED binding at %C"); + return MATCH_ERROR; + } + + if (!seen_colons) + { + gfc_error ("'::' needed in PROCEDURE binding with explicit target" + " at %C"); + return MATCH_ERROR; + } + + m = gfc_match_name (target_buf); + if (m == MATCH_ERROR) + return m; + if (m == MATCH_NO) + { + gfc_error ("Expected binding target after '=>' at %C"); + return MATCH_ERROR; + } + target = target_buf; } - target = target_buf; - } - /* Now we should have the end. */ - m = gfc_match_eos (); - if (m == MATCH_ERROR) - return m; - if (m == MATCH_NO) - { - gfc_error ("Junk after PROCEDURE declaration at %C"); - return MATCH_ERROR; - } + /* If no target was found, it has the same name as the binding. */ + if (!target) + target = name; - /* If no target was found, it has the same name as the binding. */ - if (!target) - target = name; + /* Get the namespace to insert the symbols into. */ + ns = block->f2k_derived; + gcc_assert (ns); - /* Get the namespace to insert the symbols into. */ - ns = block->f2k_derived; - gcc_assert (ns); + /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */ + if (tb.deferred && !block->attr.abstract) + { + gfc_error ("Type '%s' containing DEFERRED binding at %C " + "is not ABSTRACT", block->name); + return MATCH_ERROR; + } - /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */ - if (tb->deferred && !block->attr.abstract) - { - gfc_error ("Type '%s' containing DEFERRED binding at %C is not ABSTRACT", - block->name); - return MATCH_ERROR; - } + /* See if we already have a binding with this name in the symtree which + would be an error. If a GENERIC already targetted this binding, it may + be already there but then typebound is still NULL. */ + stree = gfc_find_symtree (ns->tb_sym_root, name); + if (stree && stree->n.tb) + { + gfc_error ("There is already a procedure with binding name '%s' for " + "the derived type '%s' at %C", name, block->name); + return MATCH_ERROR; + } - /* See if we already have a binding with this name in the symtree which would - be an error. If a GENERIC already targetted this binding, it may be - already there but then typebound is still NULL. */ - stree = gfc_find_symtree (ns->tb_sym_root, name); - if (stree && stree->n.tb) - { - gfc_error ("There's already a procedure with binding name '%s' for the" - " derived type '%s' at %C", name, block->name); - return MATCH_ERROR; - } + /* Insert it and set attributes. */ - /* Insert it and set attributes. */ + if (!stree) + { + stree = gfc_new_symtree (&ns->tb_sym_root, name); + gcc_assert (stree); + } + stree->n.tb = gfc_get_typebound_proc (&tb); - if (!stree) - { - stree = gfc_new_symtree (&ns->tb_sym_root, name); - gcc_assert (stree); + if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific, + false)) + return MATCH_ERROR; + gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym); + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; } - stree->n.tb = tb; - - if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific, false)) - return MATCH_ERROR; - gfc_set_sym_referenced (tb->u.specific->n.sym); - return MATCH_YES; +syntax: + gfc_error ("Syntax error in PROCEDURE statement at %C"); + return MATCH_ERROR; } @@ -7615,6 +7976,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) @@ -7718,7 +8082,7 @@ gfc_match_generic (void) } else { - tb = gfc_get_typebound_proc (); + tb = gfc_get_typebound_proc (NULL); tb->where = gfc_current_locus; tb->access = tbattr.access; tb->is_generic = 1; diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index e64b61c3be1..ee66d216ab5 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -25,8 +25,10 @@ along with GCC; see the file COPYING3. If not see if dependencies. Ideally these would probably be merged. */ #include "config.h" +#include "system.h" #include "gfortran.h" #include "dependency.h" +#include "constructor.h" /* static declarations */ /* Enums */ @@ -37,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. */ } @@ -46,6 +49,10 @@ gfc_dependency; /* Macros */ #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0)) +/* Forward declarations */ + +static gfc_dependency check_section_vs_section (gfc_array_ref *, + gfc_array_ref *, int); /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or def if the value could not be determined. */ @@ -64,6 +71,105 @@ gfc_expr_is_one (gfc_expr *expr, int def) return mpz_cmp_si (expr->value.integer, 1) == 0; } +/* Check if two array references are known to be identical. Calls + gfc_dep_compare_expr if necessary for comparing array indices. */ + +static bool +identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2) +{ + int i; + + if (a1->type == AR_FULL && a2->type == AR_FULL) + return true; + + if (a1->type == AR_SECTION && a2->type == AR_SECTION) + { + gcc_assert (a1->dimen == a2->dimen); + + for ( i = 0; i < a1->dimen; i++) + { + /* TODO: Currently, we punt on an integer array as an index. */ + if (a1->dimen_type[i] != DIMEN_RANGE + || a2->dimen_type[i] != DIMEN_RANGE) + return false; + + if (check_section_vs_section (a1, a2, i) != GFC_DEP_EQUAL) + return false; + } + return true; + } + + if (a1->type == AR_ELEMENT && a2->type == AR_ELEMENT) + { + gcc_assert (a1->dimen == a2->dimen); + for (i = 0; i < a1->dimen; i++) + { + if (gfc_dep_compare_expr (a1->start[i], a2->start[i]) != 0) + return false; + } + return true; + } + return false; +} + + + +/* Return true for identical variables, checking for references if + necessary. Calls identical_array_ref for checking array sections. */ + +bool +gfc_are_identical_variables (gfc_expr *e1, gfc_expr *e2) +{ + gfc_ref *r1, *r2; + + if (e1->symtree->n.sym != e2->symtree->n.sym) + return false; + + r1 = e1->ref; + r2 = e2->ref; + + while (r1 != NULL || r2 != NULL) + { + + /* Assume the variables are not equal if one has a reference and the + other doesn't. + TODO: Handle full references like comparing a(:) to a. + */ + + if (r1 == NULL || r2 == NULL) + return false; + + if (r1->type != r2->type) + return false; + + switch (r1->type) + { + + case REF_ARRAY: + if (!identical_array_ref (&r1->u.ar, &r2->u.ar)) + return false; + + break; + + case REF_COMPONENT: + if (r1->u.c.component != r2->u.c.component) + return false; + break; + + case REF_SUBSTRING: + if (gfc_dep_compare_expr (r1->u.ss.start, r2->u.ss.start) != 0 + || gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end) != 0) + return false; + break; + + default: + gfc_internal_error ("gfc_are_identical_variables: Bad type"); + } + r1 = r1->next; + r2 = r2->next; + } + return true; +} /* Compare two values. Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2, and -2 if the relationship could not be determined. */ @@ -74,7 +180,45 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2) gfc_actual_arglist *args1; gfc_actual_arglist *args2; int i; + gfc_expr *n1, *n2; + + n1 = NULL; + n2 = NULL; + + /* Remove any integer conversion functions to larger types. */ + if (e1->expr_type == EXPR_FUNCTION && e1->value.function.isym + && e1->value.function.isym->id == GFC_ISYM_CONVERSION + && e1->ts.type == BT_INTEGER) + { + args1 = e1->value.function.actual; + if (args1->expr->ts.type == BT_INTEGER + && e1->ts.kind > args1->expr->ts.kind) + n1 = args1->expr; + } + if (e2->expr_type == EXPR_FUNCTION && e2->value.function.isym + && e2->value.function.isym->id == GFC_ISYM_CONVERSION + && e2->ts.type == BT_INTEGER) + { + args2 = e2->value.function.actual; + if (args2->expr->ts.type == BT_INTEGER + && e2->ts.kind > args2->expr->ts.kind) + n2 = args2->expr; + } + + if (n1 != NULL) + { + if (n2 != NULL) + return gfc_dep_compare_expr (n1, n2); + else + return gfc_dep_compare_expr (n1, e2); + } + else + { + if (n2 != NULL) + return gfc_dep_compare_expr (e1, n2); + } + if (e1->expr_type == EXPR_OP && (e1->value.op.op == INTRINSIC_UPLUS || e1->value.op.op == INTRINSIC_PARENTHESES)) @@ -188,11 +332,10 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2) return 1; case EXPR_VARIABLE: - if (e1->ref || e2->ref) - return -2; - if (e1->symtree->n.sym == e2->symtree->n.sym) + if (gfc_are_identical_variables (e1, e2)) return 0; - return -2; + else + return -2; case EXPR_OP: /* Intrinsic operators are the same if their operands are the same. */ @@ -210,53 +353,38 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2) return -2; case EXPR_FUNCTION: - /* We can only compare calls to the same intrinsic function. */ - if (e1->value.function.isym == 0 || e2->value.function.isym == 0 - || e1->value.function.isym != e2->value.function.isym) - return -2; - args1 = e1->value.function.actual; - args2 = e2->value.function.actual; - - /* We should list the "constant" intrinsic functions. Those - without side-effects that provide equal results given equal - argument lists. */ - switch (e1->value.function.isym->id) + /* PURE functions can be compared for argument equality. */ + if ((e1->value.function.esym && e2->value.function.esym + && e1->value.function.esym == e2->value.function.esym + && e1->value.function.esym->result->attr.pure) + || (e1->value.function.isym && e2->value.function.isym + && e1->value.function.isym == e2->value.function.isym + && e1->value.function.isym->pure)) { - case GFC_ISYM_CONVERSION: - /* Handle integer extensions specially, as __convert_i4_i8 - is not only "constant" but also "unary" and "increasing". */ - if (args1 && !args1->next - && args2 && !args2->next - && e1->ts.type == BT_INTEGER - && args1->expr->ts.type == BT_INTEGER - && e1->ts.kind > args1->expr->ts.kind - && e2->ts.type == e1->ts.type - && e2->ts.kind == e1->ts.kind - && args2->expr->ts.type == args1->expr->ts.type - && args2->expr->ts.kind == args2->expr->ts.kind) - return gfc_dep_compare_expr (args1->expr, args2->expr); - break; + args1 = e1->value.function.actual; + args2 = e2->value.function.actual; - case GFC_ISYM_REAL: - case GFC_ISYM_LOGICAL: - case GFC_ISYM_DBLE: - break; + /* Compare the argument lists for equality. */ + while (args1 && args2) + { + /* Bitwise xor, since C has no non-bitwise xor operator. */ + if ((args1->expr == NULL) ^ (args2->expr == NULL)) + return -2; - default: - return -2; - } + if (args1->expr != NULL && args2->expr != NULL + && gfc_dep_compare_expr (args1->expr, args2->expr) != 0) + return -2; - /* Compare the argument lists for equality. */ - while (args1 && args2) - { - if (gfc_dep_compare_expr (args1->expr, args2->expr) != 0) - return -2; - args1 = args1->next; - args2 = args2->next; + args1 = args1->next; + args2 = args2->next; + } + return (args1 || args2) ? -2 : 0; } - return (args1 || args2) ? -2 : 0; - + else + return -2; + break; + default: return -2; } @@ -422,7 +550,7 @@ gfc_ref_needs_temporary_p (gfc_ref *ref) } -int +static int gfc_is_data_pointer (gfc_expr *e) { gfc_ref *ref; @@ -499,11 +627,15 @@ gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent, return gfc_check_dependency (var, expr, 1); case EXPR_FUNCTION: - if (intent != INTENT_IN && expr->inline_noncopying_intrinsic - && (arg = gfc_get_noncopying_intrinsic_argument (expr)) - && gfc_check_argument_var_dependency (var, intent, arg, elemental)) - return 1; - if (elemental) + if (intent != INTENT_IN) + { + arg = gfc_get_noncopying_intrinsic_argument (expr); + if (arg != NULL) + return gfc_check_argument_var_dependency (var, intent, arg, + NOT_ELEMENTAL); + } + + if (elemental != NOT_ELEMENTAL) { if ((expr->value.function.esym && expr->value.function.esym->attr.elemental) @@ -555,12 +687,11 @@ gfc_check_argument_dependency (gfc_expr *other, sym_intent intent, return gfc_check_argument_var_dependency (other, intent, expr, elemental); case EXPR_FUNCTION: - if (other->inline_noncopying_intrinsic) - { - other = gfc_get_noncopying_intrinsic_argument (other); - return gfc_check_argument_dependency (other, INTENT_IN, expr, - elemental); - } + other = gfc_get_noncopying_intrinsic_argument (other); + if (other != NULL) + return gfc_check_argument_dependency (other, INTENT_IN, expr, + NOT_ELEMENTAL); + return 0; default: @@ -805,6 +936,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; @@ -816,13 +960,14 @@ 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; case EXPR_FUNCTION: - if (expr2->inline_noncopying_intrinsic) + if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL) identical = 1; + /* Remember possible differences between elemental and transformational functions. All functions inside a FORALL will be pure. */ @@ -843,7 +988,8 @@ gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical) case EXPR_ARRAY: /* Loop through the array constructor's elements. */ - for (c = expr2->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (expr2->value.constructor); + c; c = gfc_constructor_next (c)) { /* If this is an iterator, assume the worst. */ if (c->iterator) @@ -865,9 +1011,8 @@ gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical) /* Determines overlapping for two array sections. */ static gfc_dependency -gfc_check_section_vs_section (gfc_ref *lref, gfc_ref *rref, int n) +check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n) { - gfc_array_ref l_ar; gfc_expr *l_start; gfc_expr *l_end; gfc_expr *l_stride; @@ -875,42 +1020,39 @@ gfc_check_section_vs_section (gfc_ref *lref, gfc_ref *rref, int n) gfc_expr *l_upper; int l_dir; - gfc_array_ref r_ar; gfc_expr *r_start; gfc_expr *r_end; gfc_expr *r_stride; gfc_expr *r_lower; gfc_expr *r_upper; int r_dir; + bool identical_strides; - l_ar = lref->u.ar; - r_ar = rref->u.ar; - /* If they are the same range, return without more ado. */ - if (gfc_is_same_range (&l_ar, &r_ar, n, 0)) + if (gfc_is_same_range (l_ar, r_ar, n, 0)) return GFC_DEP_EQUAL; - l_start = l_ar.start[n]; - l_end = l_ar.end[n]; - l_stride = l_ar.stride[n]; + l_start = l_ar->start[n]; + l_end = l_ar->end[n]; + l_stride = l_ar->stride[n]; - r_start = r_ar.start[n]; - r_end = r_ar.end[n]; - r_stride = r_ar.stride[n]; + r_start = r_ar->start[n]; + r_end = r_ar->end[n]; + r_stride = r_ar->stride[n]; /* If l_start is NULL take it from array specifier. */ - if (NULL == l_start && IS_ARRAY_EXPLICIT (l_ar.as)) - l_start = l_ar.as->lower[n]; + if (NULL == l_start && IS_ARRAY_EXPLICIT (l_ar->as)) + l_start = l_ar->as->lower[n]; /* If l_end is NULL take it from array specifier. */ - if (NULL == l_end && IS_ARRAY_EXPLICIT (l_ar.as)) - l_end = l_ar.as->upper[n]; + if (NULL == l_end && IS_ARRAY_EXPLICIT (l_ar->as)) + l_end = l_ar->as->upper[n]; /* If r_start is NULL take it from array specifier. */ - if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar.as)) - r_start = r_ar.as->lower[n]; + if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar->as)) + r_start = r_ar->as->lower[n]; /* If r_end is NULL take it from array specifier. */ - if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar.as)) - r_end = r_ar.as->upper[n]; + if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar->as)) + r_end = r_ar->as->upper[n]; /* Determine whether the l_stride is positive or negative. */ if (!l_stride) @@ -938,6 +1080,23 @@ gfc_check_section_vs_section (gfc_ref *lref, gfc_ref *rref, int n) if (l_dir == 0 || r_dir == 0) return GFC_DEP_OVERLAP; + /* Determine if the strides are equal. */ + + if (l_stride) + { + if (r_stride) + identical_strides = gfc_dep_compare_expr (l_stride, r_stride) == 0; + else + identical_strides = gfc_expr_is_one (l_stride, 0) == 1; + } + else + { + if (r_stride) + identical_strides = gfc_expr_is_one (r_stride, 0) == 1; + else + identical_strides = true; + } + /* Determine LHS upper and lower bounds. */ if (l_dir == 1) { @@ -996,16 +1155,48 @@ gfc_check_section_vs_section (gfc_ref *lref, gfc_ref *rref, int n) return GFC_DEP_EQUAL; } + /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP. + There is no dependency if the remainder of + (l_start - r_start) / gcd(l_stride, r_stride) is + nonzero. + TODO: + - Handle cases where x is an expression. + - Cases like a(1:4:2) = a(2:3) are still not handled. + */ + +#define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \ + && (a)->ts.type == BT_INTEGER) + + if (IS_CONSTANT_INTEGER(l_start) && IS_CONSTANT_INTEGER(r_start) + && IS_CONSTANT_INTEGER(l_stride) && IS_CONSTANT_INTEGER(r_stride)) + { + mpz_t gcd, tmp; + int result; + + mpz_init (gcd); + mpz_init (tmp); + + mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer); + mpz_sub (tmp, l_start->value.integer, r_start->value.integer); + + mpz_fdiv_r (tmp, tmp, gcd); + result = mpz_cmp_si (tmp, 0L); + + mpz_clear (gcd); + mpz_clear (tmp); + + if (result != 0) + return GFC_DEP_NODEP; + } + +#undef IS_CONSTANT_INTEGER + /* Check for forward dependencies 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) { - /* Check that the strides are the same. */ - if (!l_stride && !r_stride) - return GFC_DEP_FORWARD; - if (l_stride && r_stride - && gfc_dep_compare_expr (l_stride, r_stride) == 0) + if (identical_strides) return GFC_DEP_FORWARD; } @@ -1014,14 +1205,50 @@ gfc_check_section_vs_section (gfc_ref *lref, gfc_ref *rref, int n) && 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) { - /* Check that the strides are the same. */ - if (!l_stride && !r_stride) - return GFC_DEP_FORWARD; - if (l_stride && r_stride - && gfc_dep_compare_expr (l_stride, r_stride) == 0) + if (identical_strides) return GFC_DEP_FORWARD; } + + if (identical_strides) + { + + if (l_start && IS_ARRAY_EXPLICIT (l_ar->as)) + { + + /* Check for a(low:y:s) vs. a(z:a:s) where a has a lower bound + of low, which is always at least a forward dependence. */ + + if (r_dir == 1 + && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0) + return GFC_DEP_FORWARD; + + /* Check for a(high:y:-s) vs. a(z:a:-s) where a has a higher bound + of high, which is always at least a forward dependence. */ + + if (r_dir == -1 + && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0) + return GFC_DEP_FORWARD; + } + + /* From here, check for backwards dependencies. */ + /* 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; } @@ -1190,7 +1417,8 @@ contains_forall_index_p (gfc_expr *expr) case EXPR_STRUCTURE: case EXPR_ARRAY: - for (c = expr->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; gfc_constructor_next (c)) if (contains_forall_index_p (c->expr)) return true; break; @@ -1428,16 +1656,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. */ @@ -1490,9 +1721,10 @@ 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); + this_dep = check_section_vs_section (&lref->u.ar, &rref->u.ar, n); else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT && rref->u.ar.dimen_type[n] == DIMEN_RANGE) this_dep = gfc_check_element_vs_section (lref, rref, n); @@ -1510,6 +1742,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 (this_dep == GFC_DEP_BACKWARD + && (reverse == NULL || 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) @@ -1525,7 +1789,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 @@ -1548,4 +1812,3 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref) return fin_dep == GFC_DEP_OVERLAP; } - diff --git a/gcc/fortran/dependency.h b/gcc/fortran/dependency.h index 6fa0416e2a7..c2f7229390c 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,5 +40,8 @@ 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 *); + +bool gfc_are_identical_variables (gfc_expr *, gfc_expr *); + diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 6c67e7dedf3..14cd3bc3c66 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -32,7 +32,9 @@ along with GCC; see the file COPYING3. If not see TODO: Dump DATA. */ #include "config.h" +#include "system.h" #include "gfortran.h" +#include "constructor.h" /* Keep track of indentation for symbol tree dumps. */ static int show_level = 0; @@ -47,6 +49,20 @@ static void show_code_node (int, gfc_code *); static void show_namespace (gfc_namespace *ns); +/* Allow dumping of an expression in the debugger. */ +void gfc_debug_expr (gfc_expr *); + +void +gfc_debug_expr (gfc_expr *e) +{ + FILE *tmp = dumpfile; + dumpfile = stderr; + show_expr (e); + fputc ('\n', dumpfile); + dumpfile = tmp; +} + + /* Do indentation for a specific level. */ static inline void @@ -141,9 +157,9 @@ show_array_spec (gfc_array_spec *as) return; } - fprintf (dumpfile, "(%d", as->rank); + fprintf (dumpfile, "(%d [%d]", as->rank, as->corank); - if (as->rank != 0) + if (as->rank + as->corank > 0) { switch (as->type) { @@ -157,7 +173,7 @@ show_array_spec (gfc_array_spec *as) } fprintf (dumpfile, " %s ", c); - for (i = 0; i < as->rank; i++) + for (i = 0; i < as->rank + as->corank; i++) { show_expr (as->lower[i]); fputc (' ', dumpfile); @@ -271,9 +287,10 @@ show_ref (gfc_ref *p) /* Display a constructor. Works recursively for array constructors. */ static void -show_constructor (gfc_constructor *c) +show_constructor (gfc_constructor_base base) { - for (; c; c = c->next) + gfc_constructor *c; + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { if (c->iterator == NULL) show_expr (c->expr); @@ -294,7 +311,7 @@ show_constructor (gfc_constructor *c) fputc (')', dumpfile); } - if (c->next != NULL) + if (gfc_constructor_next (c) != NULL) fputs (" , ", dumpfile); } } @@ -591,8 +608,12 @@ show_attr (symbol_attribute *attr) fputs (" ALLOCATABLE", dumpfile); if (attr->asynchronous) fputs (" ASYNCHRONOUS", dumpfile); + if (attr->codimension) + fputs (" CODIMENSION", dumpfile); if (attr->dimension) fputs (" DIMENSION", dumpfile); + if (attr->contiguous) + fputs (" CONTIGUOUS", dumpfile); if (attr->external) fputs (" EXTERNAL", dumpfile); if (attr->intrinsic) @@ -789,6 +810,15 @@ show_symbol (gfc_symbol *sym) fprintf (dumpfile, "symbol %s ", sym->name); show_typespec (&sym->ts); + + /* If this symbol is an associate-name, show its target expression. */ + if (sym->assoc) + { + fputs (" => ", dumpfile); + show_expr (sym->assoc->target); + fputs (" ", dumpfile); + } + show_attr (&sym->attr); if (sym->value) @@ -848,7 +878,7 @@ show_symbol (gfc_symbol *sym) } } - if (sym->formal_ns) + if (sym->formal_ns && (sym->formal_ns->proc_name != sym)) { show_indent (); fputs ("Formal namespace", dumpfile); @@ -1170,6 +1200,7 @@ show_code_node (int level, gfc_code *c) gfc_filepos *fp; gfc_inquire *i; gfc_dt *dt; + gfc_namespace *ns; code_indent (level, c->here); @@ -1369,6 +1400,22 @@ show_code_node (int level, gfc_code *c) fputs ("ENDIF", dumpfile); break; + case EXEC_BLOCK: + { + const char* blocktype; + if (c->ext.block.assoc) + blocktype = "ASSOCIATE"; + else + blocktype = "BLOCK"; + show_indent (); + fprintf (dumpfile, "%s ", blocktype); + ns = c->ext.block.ns; + show_namespace (ns); + show_indent (); + fprintf (dumpfile, "END %s ", blocktype); + break; + } + case EXEC_SELECT: d = c->block; fputs ("SELECT CASE ", dumpfile); @@ -2139,7 +2186,7 @@ show_namespace (gfc_namespace *ns) fputc ('\n', dumpfile); fputc ('\n', dumpfile); - show_code (0, ns->code); + show_code (show_level, ns->code); for (ns = ns->contained; ns; ns = ns->sibling) { diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c index b05e669c370..30928286c98 100644 --- a/gcc/fortran/error.c +++ b/gcc/fortran/error.c @@ -471,7 +471,7 @@ error_print (const char *type, const char *format0, va_list argp) locus *l1, *l2, *loc; const char *format; - l1 = l2 = NULL; + loc = l1 = l2 = NULL; have_l1 = 0; pos = -1; diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index d85f23cd2ad..76ceec95715 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -26,8 +26,19 @@ along with GCC; see the file COPYING3. If not see #include "arith.h" #include "match.h" #include "target-memory.h" /* for gfc_convert_boz */ +#include "constructor.h" -/* Get a new expr node. */ + +/* The following set of functions provide access to gfc_expr* of + various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE. + + There are two functions available elsewhere that provide + slightly different flavours of variables. Namely: + expr.c (gfc_get_variable_expr) + symbol.c (gfc_lval_expr_from_sym) + TODO: Merge these functions, if possible. */ + +/* Get a new expression node. */ gfc_expr * gfc_get_expr (void) @@ -39,92 +50,349 @@ gfc_get_expr (void) e->shape = NULL; e->ref = NULL; e->symtree = NULL; - e->con_by_offset = NULL; return e; } -/* Free an argument list and everything below it. */ +/* Get a new expression node that is an array constructor + of given type and kind. */ -void -gfc_free_actual_arglist (gfc_actual_arglist *a1) +gfc_expr * +gfc_get_array_expr (bt type, int kind, locus *where) { - gfc_actual_arglist *a2; + gfc_expr *e; - while (a1) - { - a2 = a1->next; - gfc_free_expr (a1->expr); - gfc_free (a1); - a1 = a2; - } + e = gfc_get_expr (); + e->expr_type = EXPR_ARRAY; + e->value.constructor = NULL; + e->rank = 1; + e->shape = NULL; + + e->ts.type = type; + e->ts.kind = kind; + if (where) + e->where = *where; + + return e; } -/* Copy an arglist structure and all of the arguments. */ +/* Get a new expression node that is the NULL expression. */ -gfc_actual_arglist * -gfc_copy_actual_arglist (gfc_actual_arglist *p) +gfc_expr * +gfc_get_null_expr (locus *where) { - gfc_actual_arglist *head, *tail, *new_arg; + gfc_expr *e; - head = tail = NULL; + e = gfc_get_expr (); + e->expr_type = EXPR_NULL; + e->ts.type = BT_UNKNOWN; - for (; p; p = p->next) + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is an operator expression node. */ + +gfc_expr * +gfc_get_operator_expr (locus *where, gfc_intrinsic_op op, + gfc_expr *op1, gfc_expr *op2) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_OP; + e->value.op.op = op; + e->value.op.op1 = op1; + e->value.op.op2 = op2; + + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is an structure constructor + of given type and kind. */ + +gfc_expr * +gfc_get_structure_constructor_expr (bt type, int kind, locus *where) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_STRUCTURE; + e->value.constructor = NULL; + + e->ts.type = type; + e->ts.kind = kind; + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is an constant of given type and kind. */ + +gfc_expr * +gfc_get_constant_expr (bt type, int kind, locus *where) +{ + gfc_expr *e; + + if (!where) + gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL"); + + e = gfc_get_expr (); + + e->expr_type = EXPR_CONSTANT; + e->ts.type = type; + e->ts.kind = kind; + e->where = *where; + + switch (type) { - new_arg = gfc_get_actual_arglist (); - *new_arg = *p; + case BT_INTEGER: + mpz_init (e->value.integer); + break; - new_arg->expr = gfc_copy_expr (p->expr); - new_arg->next = NULL; + case BT_REAL: + gfc_set_model_kind (kind); + mpfr_init (e->value.real); + break; - if (head == NULL) - head = new_arg; - else - tail->next = new_arg; + case BT_COMPLEX: + gfc_set_model_kind (kind); + mpc_init2 (e->value.complex, mpfr_get_default_prec()); + break; - tail = new_arg; + default: + break; } - return head; + return e; } -/* Free a list of reference structures. */ +/* Get a new expression node that is an string constant. + If no string is passed, a string of len is allocated, + blanked and null-terminated. */ -void -gfc_free_ref_list (gfc_ref *p) +gfc_expr * +gfc_get_character_expr (int kind, locus *where, const char *src, int len) { - gfc_ref *q; - int i; + gfc_expr *e; + gfc_char_t *dest; - for (; p; p = q) + if (!src) { - q = p->next; + dest = gfc_get_wide_string (len + 1); + gfc_wide_memset (dest, ' ', len); + dest[len] = '\0'; + } + else + dest = gfc_char_to_widechar (src); - switch (p->type) + e = gfc_get_constant_expr (BT_CHARACTER, kind, + where ? where : &gfc_current_locus); + e->value.character.string = dest; + e->value.character.length = len; + + return e; +} + + +/* Get a new expression node that is an integer constant. */ + +gfc_expr * +gfc_get_int_expr (int kind, locus *where, int value) +{ + gfc_expr *p; + p = gfc_get_constant_expr (BT_INTEGER, kind, + where ? where : &gfc_current_locus); + + mpz_set_si (p->value.integer, value); + + return p; +} + + +/* Get a new expression node that is a logical constant. */ + +gfc_expr * +gfc_get_logical_expr (int kind, locus *where, bool value) +{ + gfc_expr *p; + p = gfc_get_constant_expr (BT_LOGICAL, kind, + where ? where : &gfc_current_locus); + + p->value.logical = value; + + return p; +} + + +gfc_expr * +gfc_get_iokind_expr (locus *where, io_kind k) +{ + gfc_expr *e; + + /* Set the types to something compatible with iokind. This is needed to + get through gfc_free_expr later since iokind really has no Basic Type, + BT, of its own. */ + + e = gfc_get_expr (); + e->expr_type = EXPR_CONSTANT; + e->ts.type = BT_LOGICAL; + e->value.iokind = k; + e->where = *where; + + return e; +} + + +/* Given an expression pointer, return a copy of the expression. This + subroutine is recursive. */ + +gfc_expr * +gfc_copy_expr (gfc_expr *p) +{ + gfc_expr *q; + gfc_char_t *s; + char *c; + + if (p == NULL) + return NULL; + + q = gfc_get_expr (); + *q = *p; + + switch (q->expr_type) + { + case EXPR_SUBSTRING: + s = gfc_get_wide_string (p->value.character.length + 1); + q->value.character.string = s; + memcpy (s, p->value.character.string, + (p->value.character.length + 1) * sizeof (gfc_char_t)); + break; + + case EXPR_CONSTANT: + /* Copy target representation, if it exists. */ + if (p->representation.string) { - case REF_ARRAY: - for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + c = XCNEWVEC (char, p->representation.length + 1); + q->representation.string = c; + memcpy (c, p->representation.string, (p->representation.length + 1)); + } + + /* Copy the values of any pointer components of p->value. */ + switch (q->ts.type) + { + case BT_INTEGER: + mpz_init_set (q->value.integer, p->value.integer); + break; + + case BT_REAL: + gfc_set_model_kind (q->ts.kind); + mpfr_init (q->value.real); + mpfr_set (q->value.real, p->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + gfc_set_model_kind (q->ts.kind); + mpc_init2 (q->value.complex, mpfr_get_default_prec()); + mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE); + break; + + case BT_CHARACTER: + if (p->representation.string) + q->value.character.string + = gfc_char_to_widechar (q->representation.string); + else { - gfc_free_expr (p->u.ar.start[i]); - gfc_free_expr (p->u.ar.end[i]); - gfc_free_expr (p->u.ar.stride[i]); - } + s = gfc_get_wide_string (p->value.character.length + 1); + q->value.character.string = s; + /* This is the case for the C_NULL_CHAR named constant. */ + if (p->value.character.length == 0 + && (p->ts.is_c_interop || p->ts.is_iso_c)) + { + *s = '\0'; + /* Need to set the length to 1 to make sure the NUL + terminator is copied. */ + q->value.character.length = 1; + } + else + memcpy (s, p->value.character.string, + (p->value.character.length + 1) * sizeof (gfc_char_t)); + } break; - case REF_SUBSTRING: - gfc_free_expr (p->u.ss.start); - gfc_free_expr (p->u.ss.end); + case BT_HOLLERITH: + case BT_LOGICAL: + case BT_DERIVED: + case BT_CLASS: + break; /* Already done. */ + + case BT_PROCEDURE: + case BT_VOID: + /* Should never be reached. */ + case BT_UNKNOWN: + gfc_internal_error ("gfc_copy_expr(): Bad expr node"); + /* Not reached. */ + } + + break; + + case EXPR_OP: + switch (q->value.op.op) + { + case INTRINSIC_NOT: + case INTRINSIC_PARENTHESES: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + q->value.op.op1 = gfc_copy_expr (p->value.op.op1); break; - case REF_COMPONENT: + default: /* Binary operators. */ + q->value.op.op1 = gfc_copy_expr (p->value.op.op1); + q->value.op.op2 = gfc_copy_expr (p->value.op.op2); break; } - gfc_free (p); + break; + + case EXPR_FUNCTION: + q->value.function.actual = + gfc_copy_actual_arglist (p->value.function.actual); + break; + + case EXPR_COMPCALL: + case EXPR_PPC: + q->value.compcall.actual = + gfc_copy_actual_arglist (p->value.compcall.actual); + q->value.compcall.tbp = p->value.compcall.tbp; + break; + + case EXPR_STRUCTURE: + case EXPR_ARRAY: + q->value.constructor = gfc_constructor_copy (p->value.constructor); + break; + + case EXPR_VARIABLE: + case EXPR_NULL: + break; } + + q->shape = gfc_copy_shape (p->shape, p->rank); + + q->ref = gfc_copy_ref (p->ref); + + return q; } @@ -191,7 +459,7 @@ free_expr0 (gfc_expr *e) case EXPR_ARRAY: case EXPR_STRUCTURE: - gfc_free_constructor (e->value.constructor); + gfc_constructor_free (e->value.constructor); break; case EXPR_SUBSTRING: @@ -227,13 +495,95 @@ gfc_free_expr (gfc_expr *e) { if (e == NULL) return; - if (e->con_by_offset) - splay_tree_delete (e->con_by_offset); free_expr0 (e); gfc_free (e); } +/* Free an argument list and everything below it. */ + +void +gfc_free_actual_arglist (gfc_actual_arglist *a1) +{ + gfc_actual_arglist *a2; + + while (a1) + { + a2 = a1->next; + gfc_free_expr (a1->expr); + gfc_free (a1); + a1 = a2; + } +} + + +/* Copy an arglist structure and all of the arguments. */ + +gfc_actual_arglist * +gfc_copy_actual_arglist (gfc_actual_arglist *p) +{ + gfc_actual_arglist *head, *tail, *new_arg; + + head = tail = NULL; + + for (; p; p = p->next) + { + new_arg = gfc_get_actual_arglist (); + *new_arg = *p; + + new_arg->expr = gfc_copy_expr (p->expr); + new_arg->next = NULL; + + if (head == NULL) + head = new_arg; + else + tail->next = new_arg; + + tail = new_arg; + } + + return head; +} + + +/* Free a list of reference structures. */ + +void +gfc_free_ref_list (gfc_ref *p) +{ + gfc_ref *q; + int i; + + for (; p; p = q) + { + q = p->next; + + switch (p->type) + { + case REF_ARRAY: + for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + { + gfc_free_expr (p->u.ar.start[i]); + gfc_free_expr (p->u.ar.end[i]); + gfc_free_expr (p->u.ar.stride[i]); + } + + break; + + case REF_SUBSTRING: + gfc_free_expr (p->u.ss.start); + gfc_free_expr (p->u.ss.end); + break; + + case REF_COMPONENT: + break; + } + + gfc_free (p); + } +} + + /* Graft the *src expression onto the *dest subexpression. */ void @@ -326,36 +676,6 @@ gfc_has_vector_index (gfc_expr *e) } -/* Insert a reference to the component of the given name. - Only to be used with CLASS containers. */ - -void -gfc_add_component_ref (gfc_expr *e, const char *name) -{ - gfc_ref **tail = &(e->ref); - gfc_ref *next = NULL; - gfc_symbol *derived = e->symtree->n.sym->ts.u.derived; - while (*tail != NULL) - { - if ((*tail)->type == REF_COMPONENT) - derived = (*tail)->u.c.component->ts.u.derived; - if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL) - break; - tail = &((*tail)->next); - } - if (*tail != NULL && strcmp (name, "$data") == 0) - next = *tail; - (*tail) = gfc_get_ref(); - (*tail)->next = next; - (*tail)->type = REF_COMPONENT; - (*tail)->u.c.sym = derived; - (*tail)->u.c.component = gfc_find_component (derived, name, true, true); - gcc_assert((*tail)->u.c.component); - if (!next) - e->ts = (*tail)->u.c.component->ts; -} - - /* Copy a shape array. */ mpz_t * @@ -420,147 +740,6 @@ gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim) } -/* Given an expression pointer, return a copy of the expression. This - subroutine is recursive. */ - -gfc_expr * -gfc_copy_expr (gfc_expr *p) -{ - gfc_expr *q; - gfc_char_t *s; - char *c; - - if (p == NULL) - return NULL; - - q = gfc_get_expr (); - *q = *p; - - switch (q->expr_type) - { - case EXPR_SUBSTRING: - s = gfc_get_wide_string (p->value.character.length + 1); - q->value.character.string = s; - memcpy (s, p->value.character.string, - (p->value.character.length + 1) * sizeof (gfc_char_t)); - break; - - case EXPR_CONSTANT: - /* Copy target representation, if it exists. */ - if (p->representation.string) - { - c = XCNEWVEC (char, p->representation.length + 1); - q->representation.string = c; - memcpy (c, p->representation.string, (p->representation.length + 1)); - } - - /* Copy the values of any pointer components of p->value. */ - switch (q->ts.type) - { - case BT_INTEGER: - mpz_init_set (q->value.integer, p->value.integer); - break; - - case BT_REAL: - gfc_set_model_kind (q->ts.kind); - mpfr_init (q->value.real); - mpfr_set (q->value.real, p->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - gfc_set_model_kind (q->ts.kind); - mpc_init2 (q->value.complex, mpfr_get_default_prec()); - mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE); - break; - - case BT_CHARACTER: - if (p->representation.string) - q->value.character.string - = gfc_char_to_widechar (q->representation.string); - else - { - s = gfc_get_wide_string (p->value.character.length + 1); - q->value.character.string = s; - - /* This is the case for the C_NULL_CHAR named constant. */ - if (p->value.character.length == 0 - && (p->ts.is_c_interop || p->ts.is_iso_c)) - { - *s = '\0'; - /* Need to set the length to 1 to make sure the NUL - terminator is copied. */ - q->value.character.length = 1; - } - else - memcpy (s, p->value.character.string, - (p->value.character.length + 1) * sizeof (gfc_char_t)); - } - break; - - case BT_HOLLERITH: - case BT_LOGICAL: - case BT_DERIVED: - case BT_CLASS: - break; /* Already done. */ - - case BT_PROCEDURE: - case BT_VOID: - /* Should never be reached. */ - case BT_UNKNOWN: - gfc_internal_error ("gfc_copy_expr(): Bad expr node"); - /* Not reached. */ - } - - break; - - case EXPR_OP: - switch (q->value.op.op) - { - case INTRINSIC_NOT: - case INTRINSIC_PARENTHESES: - case INTRINSIC_UPLUS: - case INTRINSIC_UMINUS: - q->value.op.op1 = gfc_copy_expr (p->value.op.op1); - break; - - default: /* Binary operators. */ - q->value.op.op1 = gfc_copy_expr (p->value.op.op1); - q->value.op.op2 = gfc_copy_expr (p->value.op.op2); - break; - } - - break; - - case EXPR_FUNCTION: - q->value.function.actual = - gfc_copy_actual_arglist (p->value.function.actual); - break; - - case EXPR_COMPCALL: - case EXPR_PPC: - q->value.compcall.actual = - gfc_copy_actual_arglist (p->value.compcall.actual); - q->value.compcall.tbp = p->value.compcall.tbp; - break; - - case EXPR_STRUCTURE: - case EXPR_ARRAY: - q->value.constructor = gfc_copy_constructor (p->value.constructor); - break; - - case EXPR_VARIABLE: - case EXPR_NULL: - break; - } - - q->shape = gfc_copy_shape (p->shape, p->rank); - - q->ref = gfc_copy_ref (p->ref); - - return q; -} - - /* Return the maximum kind of two expressions. In general, higher kind numbers mean more precision for numeric types. */ @@ -589,48 +768,6 @@ gfc_numeric_ts (gfc_typespec *ts) } -/* Returns an expression node that is an integer constant. */ - -gfc_expr * -gfc_int_expr (int i) -{ - gfc_expr *p; - - p = gfc_get_expr (); - - p->expr_type = EXPR_CONSTANT; - p->ts.type = BT_INTEGER; - p->ts.kind = gfc_default_integer_kind; - - p->where = gfc_current_locus; - mpz_init_set_si (p->value.integer, i); - - return p; -} - - -/* Returns an expression node that is a logical constant. */ - -gfc_expr * -gfc_logical_expr (int i, locus *where) -{ - gfc_expr *p; - - p = gfc_get_expr (); - - p->expr_type = EXPR_CONSTANT; - p->ts.type = BT_LOGICAL; - p->ts.kind = gfc_default_logical_kind; - - if (where == NULL) - where = &gfc_current_locus; - p->where = *where; - p->value.logical = i; - - return p; -} - - /* Return an expression node with an optional argument list attached. A variable number of gfc_expr pointers are strung together in an argument list with a NULL pointer terminating the list. */ @@ -764,7 +901,6 @@ gfc_is_constant_expr (gfc_expr *e) { gfc_constructor *c; gfc_actual_arglist *arg; - int rv; if (e == NULL) return 1; @@ -772,66 +908,55 @@ gfc_is_constant_expr (gfc_expr *e) switch (e->expr_type) { case EXPR_OP: - rv = (gfc_is_constant_expr (e->value.op.op1) - && (e->value.op.op2 == NULL - || gfc_is_constant_expr (e->value.op.op2))); - break; + return (gfc_is_constant_expr (e->value.op.op1) + && (e->value.op.op2 == NULL + || gfc_is_constant_expr (e->value.op.op2))); case EXPR_VARIABLE: - rv = 0; - break; + return 0; case EXPR_FUNCTION: + case EXPR_PPC: + case EXPR_COMPCALL: /* Specification functions are constant. */ if (check_specification_function (e) == MATCH_YES) - { - rv = 1; - break; - } + return 1; /* Call to intrinsic with at least one argument. */ - rv = 0; if (e->value.function.isym && e->value.function.actual) { for (arg = e->value.function.actual; arg; arg = arg->next) - { - if (!gfc_is_constant_expr (arg->expr)) - break; - } - if (arg == NULL) - rv = 1; + if (!gfc_is_constant_expr (arg->expr)) + return 0; + + return 1; } - break; + else + return 0; case EXPR_CONSTANT: case EXPR_NULL: - rv = 1; - break; + return 1; case EXPR_SUBSTRING: - rv = e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start) - && gfc_is_constant_expr (e->ref->u.ss.end)); - break; + return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start) + && gfc_is_constant_expr (e->ref->u.ss.end)); case EXPR_STRUCTURE: - rv = 0; - for (c = e->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) if (!gfc_is_constant_expr (c->expr)) - break; + return 0; - if (c == NULL) - rv = 1; - break; + return 1; case EXPR_ARRAY: - rv = gfc_constant_ac (e); - break; + return gfc_constant_ac (e); default: gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type"); + return 0; } - - return rv; } @@ -1003,11 +1128,12 @@ simplify_intrinsic_op (gfc_expr *p, int type) with gfc_simplify_expr(). */ static gfc_try -simplify_constructor (gfc_constructor *c, int type) +simplify_constructor (gfc_constructor_base base, int type) { + gfc_constructor *c; gfc_expr *p; - for (; c; c = c->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { if (c->iterator && (gfc_simplify_expr (c->iterator->start, type) == FAILURE @@ -1039,7 +1165,7 @@ simplify_constructor (gfc_constructor *c, int type) /* Pull a single array element out of an array constructor. */ static gfc_try -find_array_element (gfc_constructor *cons, gfc_array_ref *ar, +find_array_element (gfc_constructor_base base, gfc_array_ref *ar, gfc_constructor **rval) { unsigned long nelemen; @@ -1048,6 +1174,7 @@ find_array_element (gfc_constructor *cons, gfc_array_ref *ar, mpz_t offset; mpz_t span; mpz_t tmp; + gfc_constructor *cons; gfc_expr *e; gfc_try t; @@ -1102,16 +1229,13 @@ find_array_element (gfc_constructor *cons, gfc_array_ref *ar, mpz_mul (span, span, tmp); } - for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--) + for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset); + cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--) { - if (cons) + if (cons->iterator) { - if (cons->iterator) - { - cons = NULL; - goto depart; - } - cons = cons->next; + cons = NULL; + goto depart; } } @@ -1130,20 +1254,21 @@ depart: /* Find a component of a structure constructor. */ static gfc_constructor * -find_component_ref (gfc_constructor *cons, gfc_ref *ref) +find_component_ref (gfc_constructor_base base, gfc_ref *ref) { gfc_component *comp; gfc_component *pick; + gfc_constructor *c = gfc_constructor_first (base); comp = ref->u.c.sym->components; pick = ref->u.c.component; while (comp != pick) { comp = comp->next; - cons = cons->next; + c = gfc_constructor_next (c); } - return cons; + return c; } @@ -1177,6 +1302,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) int rank; int d; int shape_i; + int limit; long unsigned one = 1; bool incr_ctr; mpz_t start[GFC_MAX_DIMENSIONS]; @@ -1188,15 +1314,13 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) mpz_t tmp_mpz; mpz_t nelts; mpz_t ptr; - mpz_t index; - gfc_constructor *cons; - gfc_constructor *base; + gfc_constructor_base base; + gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS]; gfc_expr *begin; gfc_expr *finish; gfc_expr *step; gfc_expr *upper; gfc_expr *lower; - gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c; gfc_try t; t = SUCCESS; @@ -1238,6 +1362,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ { + gfc_constructor *ci; gcc_assert (begin); if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin)) @@ -1254,16 +1379,16 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) break; } - vecsub[d] = begin->value.constructor; + vecsub[d] = gfc_constructor_first (begin->value.constructor); mpz_set (ctr[d], vecsub[d]->expr->value.integer); mpz_mul (nelts, nelts, begin->shape[0]); mpz_set (expr->shape[shape_i++], begin->shape[0]); /* Check bounds. */ - for (c = vecsub[d]; c; c = c->next) + for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci)) { - if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0 - || mpz_cmp (c->expr->value.integer, + if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0 + || mpz_cmp (ci->expr->value.integer, lower->value.integer) < 0) { gfc_error ("index in dimension %d is out of bounds " @@ -1344,9 +1469,8 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) mpz_mul (delta_mpz, delta_mpz, tmp_mpz); } - mpz_init (index); mpz_init (ptr); - cons = base; + cons = gfc_constructor_first (base); /* Now clock through the array reference, calculating the index in the source constructor and transferring the elements to the new @@ -1372,11 +1496,11 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) { gcc_assert(vecsub[d]); - if (!vecsub[d]->next) - vecsub[d] = ref->u.ar.start[d]->value.constructor; + if (!gfc_constructor_next (vecsub[d])) + vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor); else { - vecsub[d] = vecsub[d]->next; + vecsub[d] = gfc_constructor_next (vecsub[d]); incr_ctr = false; } mpz_set (ctr[d], vecsub[d]->expr->value.integer); @@ -1394,25 +1518,24 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) } } - /* There must be a better way of dealing with negative strides - than resetting the index and the constructor pointer! */ - if (mpz_cmp (ptr, index) < 0) - { - mpz_set_ui (index, 0); - cons = base; - } - - while (cons && cons->next && mpz_cmp (ptr, index) > 0) - { - mpz_add_ui (index, index, one); - cons = cons->next; + limit = mpz_get_ui (ptr); + if (limit >= gfc_option.flag_max_array_constructor) + { + 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", &expr->where, + gfc_option.flag_max_array_constructor); + return FAILURE; } - gfc_append_constructor (expr, gfc_copy_expr (cons->expr)); + cons = gfc_constructor_lookup (base, limit); + gcc_assert (cons); + gfc_constructor_append_expr (&expr->value.constructor, + gfc_copy_expr (cons->expr), NULL); } mpz_clear (ptr); - mpz_clear (index); cleanup: @@ -1427,7 +1550,7 @@ cleanup: mpz_clear (ctr[d]); mpz_clear (stride[d]); } - gfc_free_constructor (base); + gfc_constructor_free (base); return t; } @@ -1468,7 +1591,7 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp) static gfc_try simplify_const_ref (gfc_expr *p) { - gfc_constructor *cons; + gfc_constructor *cons, *c; gfc_expr *newp; gfc_ref *last_ref; @@ -1508,20 +1631,20 @@ simplify_const_ref (gfc_expr *p) if (p->ref->next != NULL && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED)) { - cons = p->value.constructor; - for (; cons; cons = cons->next) + for (c = gfc_constructor_first (p->value.constructor); + c; c = gfc_constructor_next (c)) { - cons->expr->ref = gfc_copy_ref (p->ref->next); - if (simplify_const_ref (cons->expr) == FAILURE) + c->expr->ref = gfc_copy_ref (p->ref->next); + if (simplify_const_ref (c->expr) == FAILURE) return FAILURE; } if (p->ts.type == BT_DERIVED && p->ref->next - && p->value.constructor) + && (c = gfc_constructor_first (p->value.constructor))) { /* There may have been component references. */ - p->ts = p->value.constructor->expr->ts; + p->ts = c->expr->ts; } last_ref = p->ref; @@ -1535,9 +1658,9 @@ simplify_const_ref (gfc_expr *p) character length according to the first element (as all should have the same length). */ int string_len; - if (p->value.constructor) + if ((c = gfc_constructor_first (p->value.constructor))) { - const gfc_expr* first = p->value.constructor->expr; + const gfc_expr* first = c->expr; gcc_assert (first->expr_type == EXPR_CONSTANT); gcc_assert (first->ts.type == BT_CHARACTER); string_len = first->value.character.length; @@ -1551,7 +1674,9 @@ simplify_const_ref (gfc_expr *p) else gfc_free_expr (p->ts.u.cl->length); - p->ts.u.cl->length = gfc_int_expr (string_len); + p->ts.u.cl->length + = gfc_get_int_expr (gfc_default_integer_kind, + NULL, string_len); } } gfc_free_ref_list (p->ref); @@ -1722,7 +1847,9 @@ gfc_simplify_expr (gfc_expr *p, int type) p->value.character.string = s; p->value.character.length = end - start; p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - p->ts.u.cl->length = gfc_int_expr (p->value.character.length); + p->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + NULL, + p->value.character.length); gfc_free_ref_list (p->ref); p->ref = NULL; p->expr_type = EXPR_CONSTANT; @@ -1738,7 +1865,7 @@ gfc_simplify_expr (gfc_expr *p, int type) /* Only substitute array parameter variables if we are in an initialization expression, or we want a subsection. */ if (p->symtree->n.sym->attr.flavor == FL_PARAMETER - && (gfc_init_expr || p->ref + && (gfc_init_expr_flag || p->ref || p->symtree->n.sym->value->expr_type != EXPR_ARRAY)) { if (simplify_parameter_variable (p, type) == FAILURE) @@ -1767,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; @@ -1810,10 +1937,12 @@ static gfc_try scalarize_intrinsic_call (gfc_expr *e) { gfc_actual_arglist *a, *b; - gfc_constructor *args[5], *ctor, *new_ctor; + gfc_constructor_base ctor; + gfc_constructor *args[5]; + gfc_constructor *ci, *new_ctor; gfc_expr *expr, *old; int n, i, rank[5], array_arg; - + /* Find which, if any, arguments are arrays. Assume that the old expression carries the type information and that the first arg that is an array expression carries all the shape information.*/ @@ -1834,9 +1963,8 @@ scalarize_intrinsic_call (gfc_expr *e) old = gfc_copy_expr (e); - gfc_free_constructor (expr->value.constructor); + gfc_constructor_free (expr->value.constructor); expr->value.constructor = NULL; - expr->ts = old->ts; expr->where = old->where; expr->expr_type = EXPR_ARRAY; @@ -1856,7 +1984,7 @@ scalarize_intrinsic_call (gfc_expr *e) { rank[n] = a->expr->rank; ctor = a->expr->symtree->n.sym->value->value.constructor; - args[n] = gfc_copy_constructor (ctor); + args[n] = gfc_constructor_first (ctor); } else if (a->expr && a->expr->expr_type == EXPR_ARRAY) { @@ -1864,10 +1992,12 @@ scalarize_intrinsic_call (gfc_expr *e) rank[n] = a->expr->rank; else rank[n] = 1; - args[n] = gfc_copy_constructor (a->expr->value.constructor); + ctor = gfc_constructor_copy (a->expr->value.constructor); + args[n] = gfc_constructor_first (ctor); } else args[n] = NULL; + n++; } @@ -1875,53 +2005,46 @@ scalarize_intrinsic_call (gfc_expr *e) /* Using the array argument as the master, step through the array calling the function for each element and advancing the array constructors together. */ - ctor = args[array_arg - 1]; - new_ctor = NULL; - for (; ctor; ctor = ctor->next) + for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci)) { - if (expr->value.constructor == NULL) - expr->value.constructor - = new_ctor = gfc_get_constructor (); + new_ctor = gfc_constructor_append_expr (&expr->value.constructor, + gfc_copy_expr (old), NULL); + + gfc_free_actual_arglist (new_ctor->expr->value.function.actual); + a = NULL; + b = old->value.function.actual; + for (i = 0; i < n; i++) + { + if (a == NULL) + new_ctor->expr->value.function.actual + = a = gfc_get_actual_arglist (); else { - new_ctor->next = gfc_get_constructor (); - new_ctor = new_ctor->next; + a->next = gfc_get_actual_arglist (); + a = a->next; } - new_ctor->expr = gfc_copy_expr (old); - gfc_free_actual_arglist (new_ctor->expr->value.function.actual); - a = NULL; - b = old->value.function.actual; - for (i = 0; i < n; i++) - { - if (a == NULL) - new_ctor->expr->value.function.actual - = a = gfc_get_actual_arglist (); - else - { - a->next = gfc_get_actual_arglist (); - a = a->next; - } - if (args[i]) - a->expr = gfc_copy_expr (args[i]->expr); - else - a->expr = gfc_copy_expr (b->expr); - b = b->next; - } + if (args[i]) + a->expr = gfc_copy_expr (args[i]->expr); + else + a->expr = gfc_copy_expr (b->expr); + + b = b->next; + } - /* Simplify the function calls. If the simplification fails, the - error will be flagged up down-stream or the library will deal - with it. */ - gfc_simplify_expr (new_ctor->expr, 0); + /* Simplify the function calls. If the simplification fails, the + error will be flagged up down-stream or the library will deal + with it. */ + gfc_simplify_expr (new_ctor->expr, 0); - for (i = 0; i < n; i++) - if (args[i]) - args[i] = args[i]->next; + for (i = 0; i < n; i++) + if (args[i]) + args[i] = gfc_constructor_next (args[i]); - for (i = 1; i < n; i++) - if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL) - || (args[i] == NULL && args[array_arg - 1] != NULL))) - goto compliance; + for (i = 1; i < n; i++) + if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL) + || (args[i] == NULL && args[array_arg - 1] != NULL))) + goto compliance; } free_expr0 (e); @@ -2061,21 +2184,22 @@ not_numeric: static gfc_try check_alloc_comp_init (gfc_expr *e) { - gfc_component *c; + gfc_component *comp; gfc_constructor *ctor; gcc_assert (e->expr_type == EXPR_STRUCTURE); gcc_assert (e->ts.type == BT_DERIVED); - for (c = e->ts.u.derived->components, ctor = e->value.constructor; - c; c = c->next, ctor = ctor->next) + for (comp = e->ts.u.derived->components, + ctor = gfc_constructor_first (e->value.constructor); + comp; comp = comp->next, ctor = gfc_constructor_next (ctor)) { - if (c->attr.allocatable + if (comp->attr.allocatable && ctor->expr->expr_type != EXPR_NULL) { gfc_error("Invalid initialization expression for ALLOCATABLE " "component '%s' in structure constructor at %L", - c->name, &ctor->expr->where); + comp->name, &ctor->expr->where); return FAILURE; } } @@ -2181,6 +2305,12 @@ check_inquiry (gfc_expr *e, int not_restricted) && ap->expr->expr_type != EXPR_VARIABLE && check_restricted (ap->expr) == FAILURE) return MATCH_ERROR; + + if (not_restricted == 0 + && ap->expr->expr_type == EXPR_VARIABLE + && ap->expr->symtree->n.sym->attr.dummy + && ap->expr->symtree->n.sym->attr.optional) + return MATCH_NO; } return MATCH_YES; @@ -2449,7 +2579,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; @@ -2472,11 +2602,11 @@ gfc_reduce_init_expr (gfc_expr *expr) { gfc_try t; - gfc_init_expr = 1; + gfc_init_expr_flag = true; t = gfc_resolve_expr (expr); if (t == SUCCESS) t = check_init_expr (expr); - gfc_init_expr = 0; + gfc_init_expr_flag = false; if (t == FAILURE) return FAILURE; @@ -2485,7 +2615,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; } @@ -2494,11 +2624,7 @@ gfc_reduce_init_expr (gfc_expr *expr) /* Match an initialization expression. We work by first matching an - expression, then reducing it to a constant. The reducing it to - constant part requires a global variable to flag the prohibition - of a non-integer exponent in -std=f95 mode. */ - -bool init_flag = false; + expression, then reducing it to a constant. */ match gfc_match_init_expr (gfc_expr **result) @@ -2509,12 +2635,12 @@ gfc_match_init_expr (gfc_expr **result) expr = NULL; - init_flag = true; + gfc_init_expr_flag = true; m = gfc_match_expr (&expr); if (m != MATCH_YES) { - init_flag = false; + gfc_init_expr_flag = false; return m; } @@ -2522,12 +2648,12 @@ gfc_match_init_expr (gfc_expr **result) if (t != SUCCESS) { gfc_free_expr (expr); - init_flag = false; + gfc_init_expr_flag = false; return MATCH_ERROR; } *result = expr; - init_flag = false; + gfc_init_expr_flag = false; return MATCH_YES; } @@ -2808,6 +2934,7 @@ check_restricted (gfc_expr *e) gfc_try gfc_specification_expr (gfc_expr *e) { + gfc_component *comp; if (e == NULL) return SUCCESS; @@ -2822,7 +2949,9 @@ gfc_specification_expr (gfc_expr *e) if (e->expr_type == EXPR_FUNCTION && !e->value.function.isym && !e->value.function.esym - && !gfc_pure (e->symtree->n.sym)) + && !gfc_pure (e->symtree->n.sym) + && (!gfc_is_proc_ptr_comp (e, &comp) + || !comp->attr.pure)) { gfc_error ("Function '%s' at %L must be PURE", e->symtree->n.sym->name, &e->where); @@ -3109,7 +3238,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { symbol_attribute attr; gfc_ref *ref; - int is_pure; + bool is_pure, rank_remap; int pointer, check_intent_in, proc_pointer; if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN @@ -3137,6 +3266,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) pointer = lvalue->symtree->n.sym->attr.pointer; proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer; + rank_remap = false; for (ref = lvalue->ref; ref; ref = ref->next) { if (pointer) @@ -3150,6 +3280,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (ref->type == REF_ARRAY && ref->next == NULL) { + int dim; + if (ref->u.ar.type == AR_FULL) break; @@ -3162,16 +3294,41 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds " "specification for '%s' in pointer assignment " - "at %L", lvalue->symtree->n.sym->name, + "at %L", lvalue->symtree->n.sym->name, &lvalue->where) == FAILURE) - return FAILURE; + return FAILURE; - gfc_error ("Pointer bounds remapping at %L is not yet implemented " - "in gfortran", &lvalue->where); - /* TODO: See PR 29785. Add checks that all lbounds are specified and - either never or always the upper-bound; strides shall not be - present. */ - return FAILURE; + /* When bounds are given, all lbounds are necessary and either all + or none of the upper bounds; no strides are allowed. If the + upper bounds are present, we may do rank remapping. */ + for (dim = 0; dim < ref->u.ar.dimen; ++dim) + { + if (!ref->u.ar.start[dim]) + { + gfc_error ("Lower bound has to be present at %L", + &lvalue->where); + return FAILURE; + } + if (ref->u.ar.stride[dim]) + { + gfc_error ("Stride must not be present at %L", + &lvalue->where); + return FAILURE; + } + + if (dim == 0) + rank_remap = (ref->u.ar.end[dim] != NULL); + else + { + if ((rank_remap && !ref->u.ar.end[dim]) + || (!rank_remap && ref->u.ar.end[dim])) + { + gfc_error ("Either all or none of the upper bounds" + " must be specified at %L", &lvalue->where); + return FAILURE; + } + } + } } } @@ -3183,8 +3340,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) } if (!pointer && !proc_pointer - && !(lvalue->ts.type == BT_CLASS - && lvalue->ts.u.derived->components->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; @@ -3205,6 +3362,20 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) return SUCCESS; + /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */ + if (lvalue->expr_type == EXPR_VARIABLE + && gfc_is_coindexed (lvalue)) + { + gfc_ref *ref; + for (ref = lvalue->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + { + gfc_error ("Pointer object at %L shall not have a coindex", + &lvalue->where); + return FAILURE; + } + } + /* Checks on rvalue for procedure pointer assignments. */ if (proc_pointer) { @@ -3319,13 +3490,47 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return FAILURE; } - if (lvalue->rank != rvalue->rank) + if (lvalue->rank != rvalue->rank && !rank_remap) { - gfc_error ("Different ranks in pointer assignment at %L", - &lvalue->where); + gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where); return FAILURE; } + /* Check rank remapping. */ + if (rank_remap) + { + mpz_t lsize, rsize; + + /* If this can be determined, check that the target must be at least as + large as the pointer assigned to it is. */ + if (gfc_array_size (lvalue, &lsize) == SUCCESS + && gfc_array_size (rvalue, &rsize) == SUCCESS + && mpz_cmp (rsize, lsize) < 0) + { + gfc_error ("Rank remapping target is smaller than size of the" + " pointer (%ld < %ld) at %L", + mpz_get_si (rsize), mpz_get_si (lsize), + &lvalue->where); + return FAILURE; + } + + /* The target must be either rank one or it must be simply contiguous + and F2008 must be allowed. */ + if (rvalue->rank != 1) + { + if (!gfc_is_simply_contiguous (rvalue, true)) + { + gfc_error ("Rank remapping target must be rank 1 or" + " simply contiguous at %L", &rvalue->where); + return FAILURE; + } + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Rank remapping" + " target is not rank 1 at %L", &rvalue->where) + == FAILURE) + return FAILURE; + } + } + /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */ if (rvalue->expr_type == EXPR_NULL) return SUCCESS; @@ -3369,6 +3574,20 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return FAILURE; } + /* F2008, C725. For PURE also C1283. */ + if (rvalue->expr_type == EXPR_VARIABLE + && gfc_is_coindexed (rvalue)) + { + gfc_ref *ref; + for (ref = rvalue->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + { + gfc_error ("Data target at %L shall not have a coindex", + &rvalue->where); + return FAILURE; + } + } + return SUCCESS; } @@ -3393,8 +3612,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 - && sym->ts.u.derived->components->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 @@ -3402,54 +3620,101 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) gfc_free (lvalue.symtree); - return r; + if (r == FAILURE) + return r; + + if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL) + { + /* F08:C461. Additional checks for pointer initialization. */ + symbol_attribute attr; + attr = gfc_expr_attr (rvalue); + if (attr.allocatable) + { + gfc_error ("Pointer initialization target at %C " + "must not be ALLOCATABLE "); + return FAILURE; + } + if (!attr.target) + { + gfc_error ("Pointer initialization target at %C " + "must have the TARGET attribute"); + return FAILURE; + } + if (!attr.save) + { + gfc_error ("Pointer initialization target at %C " + "must have the SAVE attribute"); + return FAILURE; + } + } + + return SUCCESS; } +/* Check for default initializer; sym->value is not enough + as it is also set for EXPR_NULL of allocatables. */ + +bool +gfc_has_default_initializer (gfc_symbol *der) +{ + gfc_component *c; + + gcc_assert (der->attr.flavor == FL_DERIVED); + for (c = der->components; c; c = c->next) + if (c->ts.type == BT_DERIVED) + { + if (!c->attr.pointer + && gfc_has_default_initializer (c->ts.u.derived)) + return true; + } + else + { + if (c->initializer) + return true; + } + + return false; +} + /* Get an expression for a default initializer. */ gfc_expr * gfc_default_initializer (gfc_typespec *ts) { - gfc_constructor *tail; gfc_expr *init; - gfc_component *c; + gfc_component *comp; - /* See if we have a default initializer. */ - for (c = ts->u.derived->components; c; c = c->next) - if (c->initializer || c->attr.allocatable) + /* See if we have a default initializer in this, but not in nested + types (otherwise we could use gfc_has_default_initializer()). */ + for (comp = ts->u.derived->components; comp; comp = comp->next) + if (comp->initializer || comp->attr.allocatable) break; - if (!c) + if (!comp) return NULL; - /* Build the constructor. */ - init = gfc_get_expr (); - init->expr_type = EXPR_STRUCTURE; + init = gfc_get_structure_constructor_expr (ts->type, ts->kind, + &ts->u.derived->declared_at); init->ts = *ts; - init->where = ts->u.derived->declared_at; - tail = NULL; - for (c = ts->u.derived->components; c; c = c->next) + for (comp = ts->u.derived->components; comp; comp = comp->next) { - if (tail == NULL) - init->value.constructor = tail = gfc_get_constructor (); - else - { - tail->next = gfc_get_constructor (); - tail = tail->next; - } + gfc_constructor *ctor = gfc_constructor_get(); - if (c->initializer) - tail->expr = gfc_copy_expr (c->initializer); + if (comp->initializer) + ctor->expr = gfc_copy_expr (comp->initializer); - if (c->attr.allocatable) + if (comp->attr.allocatable) { - tail->expr = gfc_get_expr (); - tail->expr->expr_type = EXPR_NULL; - tail->expr->ts = c->ts; + ctor->expr = gfc_get_expr (); + ctor->expr->expr_type = EXPR_NULL; + ctor->expr->ts = comp->ts; } + + gfc_constructor_append (&init->value.constructor, ctor); } + return init; } @@ -3560,6 +3825,8 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, switch (expr->expr_type) { + case EXPR_PPC: + case EXPR_COMPCALL: case EXPR_FUNCTION: for (args = expr->value.function.actual; args; args = args->next) { @@ -3576,7 +3843,8 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, case EXPR_STRUCTURE: case EXPR_ARRAY: - for (c = expr->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) { if (gfc_traverse_expr (c->expr, sym, func, f)) return true; @@ -3642,7 +3910,8 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, return true; if (ref->u.c.component->as) - for (i = 0; i < ref->u.c.component->as->rank; i++) + for (i = 0; i < ref->u.c.component->as->rank + + ref->u.c.component->as->corank; i++) { if (gfc_traverse_expr (ref->u.c.component->as->lower[i], sym, func, f)) @@ -3836,3 +4105,236 @@ gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest) gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0); } + +bool +gfc_is_coindexed (gfc_expr *e) +{ + gfc_ref *ref; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + return true; + + return false; +} + + +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 +gfc_has_ultimate_allocatable (gfc_expr *e) +{ + gfc_ref *ref, *last = NULL; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + last = ref; + + if (last && last->u.c.component->ts.type == BT_CLASS) + return CLASS_DATA (last->u.c.component)->attr.alloc_comp; + else if (last && last->u.c.component->ts.type == BT_DERIVED) + return last->u.c.component->ts.u.derived->attr.alloc_comp; + else if (last) + return false; + + if (e->ts.type == BT_CLASS) + return CLASS_DATA (e)->attr.alloc_comp; + else if (e->ts.type == BT_DERIVED) + return e->ts.u.derived->attr.alloc_comp; + else + return false; +} + + +/* Check whether the expression has an pointer component. + Being itself a pointer does not count. */ +bool +gfc_has_ultimate_pointer (gfc_expr *e) +{ + gfc_ref *ref, *last = NULL; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + last = ref; + + if (last && last->u.c.component->ts.type == BT_CLASS) + return CLASS_DATA (last->u.c.component)->attr.pointer_comp; + else if (last && last->u.c.component->ts.type == BT_DERIVED) + return last->u.c.component->ts.u.derived->attr.pointer_comp; + else if (last) + return false; + + if (e->ts.type == BT_CLASS) + return CLASS_DATA (e)->attr.pointer_comp; + else if (e->ts.type == BT_DERIVED) + return e->ts.u.derived->attr.pointer_comp; + else + return false; +} + + +/* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4. + Note: A scalar is not regarded as "simply contiguous" by the standard. + if bool is not strict, some futher checks are done - for instance, + a "(::1)" is accepted. */ + +bool +gfc_is_simply_contiguous (gfc_expr *expr, bool strict) +{ + bool colon; + int i; + gfc_array_ref *ar = NULL; + gfc_ref *ref, *part_ref = NULL; + + if (expr->expr_type == EXPR_FUNCTION) + return expr->value.function.esym + ? expr->value.function.esym->result->attr.contiguous : false; + else if (expr->expr_type != EXPR_VARIABLE) + return false; + + if (expr->rank == 0) + return false; + + for (ref = expr->ref; ref; ref = ref->next) + { + if (ar) + return false; /* Array shall be last part-ref. */ + + if (ref->type == REF_COMPONENT) + part_ref = ref; + else if (ref->type == REF_SUBSTRING) + return false; + else if (ref->u.ar.type != AR_ELEMENT) + ar = &ref->u.ar; + } + + if ((part_ref && !part_ref->u.c.component->attr.contiguous + && part_ref->u.c.component->attr.pointer) + || (!part_ref && !expr->symtree->n.sym->attr.contiguous + && (expr->symtree->n.sym->attr.pointer + || expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE))) + return false; + + if (!ar || ar->type == AR_FULL) + return true; + + gcc_assert (ar->type == AR_SECTION); + + /* Check for simply contiguous array */ + colon = true; + for (i = 0; i < ar->dimen; i++) + { + if (ar->dimen_type[i] == DIMEN_VECTOR) + return false; + + if (ar->dimen_type[i] == DIMEN_ELEMENT) + { + colon = false; + continue; + } + + gcc_assert (ar->dimen_type[i] == DIMEN_RANGE); + + + /* If the previous section was not contiguous, that's an error, + unless we have effective only one element and checking is not + strict. */ + if (!colon && (strict || !ar->start[i] || !ar->end[i] + || ar->start[i]->expr_type != EXPR_CONSTANT + || ar->end[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->start[i]->value.integer, + ar->end[i]->value.integer) != 0)) + return false; + + /* Following the standard, "(::1)" or - if known at compile time - + "(lbound:ubound)" are not simply contigous; if strict + is false, they are regarded as simply contiguous. */ + if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT + || ar->stride[i]->ts.type != BT_INTEGER + || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0)) + return false; + + if (ar->start[i] + && (strict || ar->start[i]->expr_type != EXPR_CONSTANT + || !ar->as->lower[i] + || ar->as->lower[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->start[i]->value.integer, + ar->as->lower[i]->value.integer) != 0)) + colon = false; + + if (ar->end[i] + && (strict || ar->end[i]->expr_type != EXPR_CONSTANT + || !ar->as->upper[i] + || ar->as->upper[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->end[i]->value.integer, + ar->as->upper[i]->value.integer) != 0)) + colon = false; + } + + return true; +} + + +/* Build call to an intrinsic procedure. The number of arguments has to be + passed (rather than ending the list with a NULL value) because we may + want to add arguments but with a NULL-expression. */ + +gfc_expr* +gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...) +{ + gfc_expr* result; + gfc_actual_arglist* atail; + gfc_intrinsic_sym* isym; + va_list ap; + unsigned i; + + isym = gfc_find_function (name); + gcc_assert (isym); + + result = gfc_get_expr (); + result->expr_type = EXPR_FUNCTION; + result->ts = isym->ts; + result->where = where; + result->value.function.name = name; + result->value.function.isym = isym; + + va_start (ap, numarg); + atail = NULL; + for (i = 0; i < numarg; ++i) + { + if (atail) + { + atail->next = gfc_get_actual_arglist (); + atail = atail->next; + } + else + atail = result->value.function.actual = gfc_get_actual_arglist (); + + atail->expr = va_arg (ap, gfc_expr*); + } + va_end (ap); + + return result; +} diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index 5d2846c8890..d00b7f0df50 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -1,5 +1,5 @@ /* gfortran backend interface - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2010 Free Software Foundation, Inc. Contributed by Paul Brook. @@ -43,11 +43,6 @@ along with GCC; see the file COPYING3. If not see #include "diagnostic.h" #include "tree-dump.h" #include "cgraph.h" -/* For gfc_maybe_initialize_eh. */ -#include "libfuncs.h" -#include "expr.h" -#include "except.h" - #include "gfortran.h" #include "cpp.h" #include "trans.h" @@ -93,6 +88,7 @@ static void gfc_init_builtin_functions (void); /* Each front end provides its own. */ static bool gfc_init (void); static void gfc_finish (void); +static void gfc_write_global_declarations (void); static void gfc_print_identifier (FILE *, tree, int); void do_function_end (void); int global_bindings_p (void); @@ -104,6 +100,8 @@ static void gfc_init_ts (void); #undef LANG_HOOKS_NAME #undef LANG_HOOKS_INIT #undef LANG_HOOKS_FINISH +#undef LANG_HOOKS_WRITE_GLOBALS +#undef LANG_HOOKS_OPTION_LANG_MASK #undef LANG_HOOKS_INIT_OPTIONS #undef LANG_HOOKS_HANDLE_OPTION #undef LANG_HOOKS_POST_OPTIONS @@ -116,6 +114,7 @@ static void gfc_init_ts (void); #undef LANG_HOOKS_INIT_TS #undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE #undef LANG_HOOKS_OMP_PREDETERMINED_SHARING +#undef LANG_HOOKS_OMP_REPORT_DECL #undef LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR #undef LANG_HOOKS_OMP_CLAUSE_COPY_CTOR #undef LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP @@ -131,6 +130,8 @@ static void gfc_init_ts (void); #define LANG_HOOKS_NAME "GNU Fortran" #define LANG_HOOKS_INIT gfc_init #define LANG_HOOKS_FINISH gfc_finish +#define LANG_HOOKS_WRITE_GLOBALS gfc_write_global_declarations +#define LANG_HOOKS_OPTION_LANG_MASK gfc_option_lang_mask #define LANG_HOOKS_INIT_OPTIONS gfc_init_options #define LANG_HOOKS_HANDLE_OPTION gfc_handle_option #define LANG_HOOKS_POST_OPTIONS gfc_post_options @@ -142,6 +143,7 @@ static void gfc_init_ts (void); #define LANG_HOOKS_INIT_TS gfc_init_ts #define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE gfc_omp_privatize_by_reference #define LANG_HOOKS_OMP_PREDETERMINED_SHARING gfc_omp_predetermined_sharing +#define LANG_HOOKS_OMP_REPORT_DECL gfc_omp_report_decl #define LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR gfc_omp_clause_default_ctor #define LANG_HOOKS_OMP_CLAUSE_COPY_CTOR gfc_omp_clause_copy_ctor #define LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP gfc_omp_clause_assign_op @@ -198,17 +200,18 @@ gfc_truthvalue_conversion (tree expr) return expr; } else if (TREE_CODE (expr) == NOP_EXPR) - return fold_build1 (NOP_EXPR, + return fold_build1_loc (input_location, NOP_EXPR, boolean_type_node, TREE_OPERAND (expr, 0)); else - return fold_build1 (NOP_EXPR, boolean_type_node, expr); + return fold_build1_loc (input_location, NOP_EXPR, boolean_type_node, + expr); case INTEGER_TYPE: if (TREE_CODE (expr) == INTEGER_CST) return integer_zerop (expr) ? boolean_false_node : boolean_true_node; else - return fold_build2 (NE_EXPR, boolean_type_node, expr, - build_int_cst (TREE_TYPE (expr), 0)); + return fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + expr, build_int_cst (TREE_TYPE (expr), 0)); default: internal_error ("Unexpected type in truthvalue_conversion"); @@ -285,6 +288,33 @@ gfc_finish (void) return; } +/* ??? This is something of a hack. + + Emulated tls lowering needs to see all TLS variables before we call + cgraph_finalize_compilation_unit. The C/C++ front ends manage this + by calling decl_rest_of_compilation on each global and static variable + as they are seen. The Fortran front end waits until this hook. + + A Correct solution is for cgraph_finalize_compilation_unit not to be + called during the WRITE_GLOBALS langhook, and have that hook only do what + its name suggests and write out globals. But the C++ and Java front ends + have (unspecified) problems with aliases that gets in the way. It has + been suggested that these problems would be solved by completing the + conversion to cgraph-based aliases. */ + +static void +gfc_write_global_declarations (void) +{ + tree decl; + + /* Finalize all of the globals. */ + for (decl = getdecls(); decl ; decl = DECL_CHAIN (decl)) + rest_of_decl_compilation (decl, true, true); + + write_global_declarations (); +} + + static void gfc_print_identifier (FILE * file ATTRIBUTE_UNUSED, tree node ATTRIBUTE_UNUSED, @@ -313,7 +343,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; @@ -355,8 +385,7 @@ getdecls (void) void pushlevel (int ignore ATTRIBUTE_UNUSED) { - struct binding_level *newlevel - = (struct binding_level *) ggc_alloc (sizeof (struct binding_level)); + struct binding_level *newlevel = ggc_alloc_binding_level (); *newlevel = clear_binding_level; @@ -413,7 +442,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. */ @@ -471,7 +500,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. */ @@ -542,7 +571,7 @@ gfc_init_decl_processing (void) /* Build common tree nodes. char_type_node is unsigned because we only use it for actual characters, not for INTEGER(1). Also, we want double_type_node to actually have double precision. */ - build_common_tree_nodes (false, false); + build_common_tree_nodes (false); /* x86_64 mingw32 has a sizetype of "unsigned long long", most other hosts have a sizetype of "unsigned long". Therefore choose the correct size in mostly target independent way. */ @@ -608,6 +637,7 @@ gfc_define_builtin (const char *name, library_name, NULL_TREE); if (const_p) TREE_READONLY (decl) = 1; + TREE_NOTHROW (decl) = 1; built_in_decls[code] = decl; implicit_built_in_decls[code] = decl; @@ -635,28 +665,23 @@ gfc_define_builtin (const char *name, static void build_builtin_fntypes (tree *fntype, tree type) { - tree tmp; - /* type (*) (type) */ - tmp = tree_cons (NULL_TREE, type, void_list_node); - fntype[0] = build_function_type (type, tmp); + fntype[0] = build_function_type_list (type, type, NULL_TREE); /* type (*) (type, type) */ - tmp = tree_cons (NULL_TREE, type, tmp); - fntype[1] = build_function_type (type, tmp); - /* type (*) (int, type) */ - tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node); - tmp = tree_cons (NULL_TREE, type, tmp); - fntype[2] = build_function_type (type, tmp); - /* type (*) (void) */ - fntype[3] = build_function_type (type, void_list_node); - /* type (*) (type, &int) */ - tmp = tree_cons (NULL_TREE, type, void_list_node); - tmp = tree_cons (NULL_TREE, build_pointer_type (integer_type_node), tmp); - fntype[4] = build_function_type (type, tmp); + fntype[1] = build_function_type_list (type, type, type, NULL_TREE); /* type (*) (type, int) */ - tmp = tree_cons (NULL_TREE, type, void_list_node); - tmp = tree_cons (NULL_TREE, integer_type_node, tmp); - fntype[5] = build_function_type (type, tmp); + fntype[2] = build_function_type_list (type, + type, integer_type_node, NULL_TREE); + /* type (*) (void) */ + fntype[3] = build_function_type_list (type, NULL_TREE); + /* type (*) (&int, type) */ + fntype[4] = build_function_type_list (type, + build_pointer_type (integer_type_node), + type, + NULL_TREE); + /* type (*) (int, type) */ + fntype[5] = build_function_type_list (type, + integer_type_node, type, NULL_TREE); } @@ -720,7 +745,6 @@ gfc_init_builtin_functions (void) tree func_double_doublep_doublep; tree func_longdouble_longdoublep_longdoublep; tree ftype, ptype; - tree tmp, type; tree builtin_types[(int) BT_LAST + 1]; build_builtin_fntypes (mfunc_float, float_type_node); @@ -730,51 +754,45 @@ gfc_init_builtin_functions (void) build_builtin_fntypes (mfunc_cdouble, complex_double_type_node); build_builtin_fntypes (mfunc_clongdouble, complex_long_double_type_node); - tmp = tree_cons (NULL_TREE, complex_float_type_node, void_list_node); - func_cfloat_float = build_function_type (float_type_node, tmp); + func_cfloat_float = build_function_type_list (float_type_node, + complex_float_type_node, + NULL_TREE); - tmp = tree_cons (NULL_TREE, float_type_node, void_list_node); - func_float_cfloat = build_function_type (complex_float_type_node, tmp); + func_float_cfloat = build_function_type_list (complex_float_type_node, + float_type_node, NULL_TREE); - tmp = tree_cons (NULL_TREE, complex_double_type_node, void_list_node); - func_cdouble_double = build_function_type (double_type_node, tmp); + func_cdouble_double = build_function_type_list (double_type_node, + complex_double_type_node, + NULL_TREE); - tmp = tree_cons (NULL_TREE, double_type_node, void_list_node); - func_double_cdouble = build_function_type (complex_double_type_node, tmp); + func_double_cdouble = build_function_type_list (complex_double_type_node, + double_type_node, NULL_TREE); - tmp = tree_cons (NULL_TREE, complex_long_double_type_node, void_list_node); func_clongdouble_longdouble = - build_function_type (long_double_type_node, tmp); + build_function_type_list (long_double_type_node, + complex_long_double_type_node, NULL_TREE); - tmp = tree_cons (NULL_TREE, long_double_type_node, void_list_node); func_longdouble_clongdouble = - build_function_type (complex_long_double_type_node, tmp); + build_function_type_list (complex_long_double_type_node, + long_double_type_node, NULL_TREE); ptype = build_pointer_type (float_type_node); - tmp = tree_cons (NULL_TREE, float_type_node, - tree_cons (NULL_TREE, ptype, - tree_cons (NULL_TREE, ptype, void_list_node))); func_float_floatp_floatp = - build_function_type (void_type_node, tmp); + build_function_type_list (void_type_node, ptype, ptype, NULL_TREE); ptype = build_pointer_type (double_type_node); - tmp = tree_cons (NULL_TREE, double_type_node, - tree_cons (NULL_TREE, ptype, - tree_cons (NULL_TREE, ptype, void_list_node))); func_double_doublep_doublep = - build_function_type (void_type_node, tmp); + build_function_type_list (void_type_node, ptype, ptype, NULL_TREE); ptype = build_pointer_type (long_double_type_node); - tmp = tree_cons (NULL_TREE, long_double_type_node, - tree_cons (NULL_TREE, ptype, - tree_cons (NULL_TREE, ptype, void_list_node))); func_longdouble_longdoublep_longdoublep = - build_function_type (void_type_node, tmp); + build_function_type_list (void_type_node, ptype, ptype, NULL_TREE); + +/* Non-math builtins are defined manually, so they're not included here. */ +#define OTHER_BUILTIN(ID,NAME,TYPE,CONST) #include "mathbuiltins.def" - /* We define these separately as the fortran versions have different - semantics (they return an integer type) */ gfc_define_builtin ("__builtin_roundl", mfunc_longdouble[0], BUILT_IN_ROUNDL, "roundl", true); gfc_define_builtin ("__builtin_round", mfunc_double[0], @@ -838,36 +856,32 @@ gfc_init_builtin_functions (void) gfc_define_builtin ("__builtin_fmodf", mfunc_float[1], BUILT_IN_FMODF, "fmodf", true); - gfc_define_builtin ("__builtin_huge_vall", mfunc_longdouble[3], - BUILT_IN_HUGE_VALL, "__builtin_huge_vall", true); - gfc_define_builtin ("__builtin_huge_val", mfunc_double[3], - BUILT_IN_HUGE_VAL, "__builtin_huge_val", true); - gfc_define_builtin ("__builtin_huge_valf", mfunc_float[3], - BUILT_IN_HUGE_VALF, "__builtin_huge_valf", true); - /* lround{f,,l} and llround{f,,l} */ - type = tree_cons (NULL_TREE, float_type_node, void_list_node); - tmp = build_function_type (long_integer_type_node, type); - gfc_define_builtin ("__builtin_lroundf", tmp, BUILT_IN_LROUNDF, + ftype = build_function_type_list (long_integer_type_node, + float_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_lroundf", ftype, BUILT_IN_LROUNDF, "lroundf", true); - tmp = build_function_type (long_long_integer_type_node, type); - gfc_define_builtin ("__builtin_llroundf", tmp, BUILT_IN_LLROUNDF, + ftype = build_function_type_list (long_long_integer_type_node, + float_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_llroundf", ftype, BUILT_IN_LLROUNDF, "llroundf", true); - type = tree_cons (NULL_TREE, double_type_node, void_list_node); - tmp = build_function_type (long_integer_type_node, type); - gfc_define_builtin ("__builtin_lround", tmp, BUILT_IN_LROUND, + ftype = build_function_type_list (long_integer_type_node, + double_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_lround", ftype, BUILT_IN_LROUND, "lround", true); - tmp = build_function_type (long_long_integer_type_node, type); - gfc_define_builtin ("__builtin_llround", tmp, BUILT_IN_LLROUND, + ftype = build_function_type_list (long_long_integer_type_node, + double_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_llround", ftype, BUILT_IN_LLROUND, "llround", true); - type = tree_cons (NULL_TREE, long_double_type_node, void_list_node); - tmp = build_function_type (long_integer_type_node, type); - gfc_define_builtin ("__builtin_lroundl", tmp, BUILT_IN_LROUNDL, + ftype = build_function_type_list (long_integer_type_node, + long_double_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_lroundl", ftype, BUILT_IN_LROUNDL, "lroundl", true); - tmp = build_function_type (long_long_integer_type_node, type); - gfc_define_builtin ("__builtin_llroundl", tmp, BUILT_IN_LLROUNDL, + ftype = build_function_type_list (long_long_integer_type_node, + long_double_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_llroundl", ftype, BUILT_IN_LLROUNDL, "llroundl", true); /* These are used to implement the ** operator. */ @@ -918,174 +932,138 @@ gfc_init_builtin_functions (void) BUILT_IN_SINCOSF, "sincosf", false); } - /* For LEADZ / TRAILZ. */ - tmp = tree_cons (NULL_TREE, unsigned_type_node, void_list_node); - ftype = build_function_type (integer_type_node, tmp); + /* For LEADZ, TRAILZ, POPCNT and POPPAR. */ + ftype = build_function_type_list (integer_type_node, + unsigned_type_node, NULL_TREE); gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ, "__builtin_clz", true); - - tmp = tree_cons (NULL_TREE, long_unsigned_type_node, void_list_node); - ftype = build_function_type (integer_type_node, tmp); - gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL, - "__builtin_clzl", true); - - tmp = tree_cons (NULL_TREE, long_long_unsigned_type_node, void_list_node); - ftype = build_function_type (integer_type_node, tmp); - gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL, - "__builtin_clzll", true); - - tmp = tree_cons (NULL_TREE, unsigned_type_node, void_list_node); - ftype = build_function_type (integer_type_node, tmp); gfc_define_builtin ("__builtin_ctz", ftype, BUILT_IN_CTZ, "__builtin_ctz", true); + gfc_define_builtin ("__builtin_parity", ftype, BUILT_IN_PARITY, + "__builtin_parity", true); + gfc_define_builtin ("__builtin_popcount", ftype, BUILT_IN_POPCOUNT, + "__builtin_popcount", true); - tmp = tree_cons (NULL_TREE, long_unsigned_type_node, void_list_node); - ftype = build_function_type (integer_type_node, tmp); + ftype = build_function_type_list (integer_type_node, + long_unsigned_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL, + "__builtin_clzl", true); gfc_define_builtin ("__builtin_ctzl", ftype, BUILT_IN_CTZL, "__builtin_ctzl", true); + gfc_define_builtin ("__builtin_parityl", ftype, BUILT_IN_PARITYL, + "__builtin_parityl", true); + gfc_define_builtin ("__builtin_popcountl", ftype, BUILT_IN_POPCOUNTL, + "__builtin_popcountl", true); - tmp = tree_cons (NULL_TREE, long_long_unsigned_type_node, void_list_node); - ftype = build_function_type (integer_type_node, tmp); + ftype = build_function_type_list (integer_type_node, + long_long_unsigned_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL, + "__builtin_clzll", true); gfc_define_builtin ("__builtin_ctzll", ftype, BUILT_IN_CTZLL, "__builtin_ctzll", true); + gfc_define_builtin ("__builtin_parityll", ftype, BUILT_IN_PARITYLL, + "__builtin_parityll", true); + gfc_define_builtin ("__builtin_popcountll", ftype, BUILT_IN_POPCOUNTLL, + "__builtin_popcountll", true); /* Other builtin functions we use. */ - tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node); - tmp = tree_cons (NULL_TREE, long_integer_type_node, tmp); - ftype = build_function_type (long_integer_type_node, tmp); + ftype = build_function_type_list (long_integer_type_node, + long_integer_type_node, + long_integer_type_node, NULL_TREE); gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT, "__builtin_expect", true); - tmp = tree_cons (NULL_TREE, pvoid_type_node, void_list_node); - ftype = build_function_type (void_type_node, tmp); + ftype = build_function_type_list (void_type_node, + pvoid_type_node, NULL_TREE); gfc_define_builtin ("__builtin_free", ftype, BUILT_IN_FREE, "free", false); - tmp = tree_cons (NULL_TREE, size_type_node, void_list_node); - ftype = build_function_type (pvoid_type_node, tmp); + ftype = build_function_type_list (pvoid_type_node, + size_type_node, NULL_TREE); gfc_define_builtin ("__builtin_malloc", ftype, BUILT_IN_MALLOC, "malloc", false); DECL_IS_MALLOC (built_in_decls[BUILT_IN_MALLOC]) = 1; - tmp = tree_cons (NULL_TREE, pvoid_type_node, void_list_node); - tmp = tree_cons (NULL_TREE, size_type_node, tmp); - ftype = build_function_type (pvoid_type_node, tmp); + ftype = build_function_type_list (pvoid_type_node, + size_type_node, pvoid_type_node, + NULL_TREE); gfc_define_builtin ("__builtin_realloc", ftype, BUILT_IN_REALLOC, "realloc", false); - tmp = tree_cons (NULL_TREE, void_type_node, void_list_node); - ftype = build_function_type (integer_type_node, tmp); + ftype = build_function_type_list (integer_type_node, + void_type_node, NULL_TREE); gfc_define_builtin ("__builtin_isnan", ftype, BUILT_IN_ISNAN, "__builtin_isnan", true); #define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \ builtin_types[(int) ENUM] = VALUE; -#define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \ - builtin_types[(int) ENUM] \ - = build_function_type (builtin_types[(int) RETURN], \ - void_list_node); +#define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \ + builtin_types[(int) ENUM] \ + = build_function_type_list (builtin_types[(int) RETURN], \ + NULL_TREE); #define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1) \ builtin_types[(int) ENUM] \ - = build_function_type (builtin_types[(int) RETURN], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG1], \ - void_list_node)); -#define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \ - builtin_types[(int) ENUM] \ - = build_function_type \ - (builtin_types[(int) RETURN], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG1], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG2], \ - void_list_node))); -#define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \ - builtin_types[(int) ENUM] \ - = build_function_type \ - (builtin_types[(int) RETURN], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG1], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG2], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG3], \ - void_list_node)))); + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \ + builtin_types[(int) ENUM] \ + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \ + builtin_types[(int) ENUM] \ + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + builtin_types[(int) ARG3], \ + NULL_TREE); #define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \ builtin_types[(int) ENUM] \ - = build_function_type \ - (builtin_types[(int) RETURN], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG1], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG2], \ - tree_cons \ - (NULL_TREE, \ - builtin_types[(int) ARG3], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG4], \ - void_list_node))))); + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + builtin_types[(int) ARG3], \ + builtin_types[(int) ARG4], \ + NULL_TREE); #define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \ builtin_types[(int) ENUM] \ - = build_function_type \ - (builtin_types[(int) RETURN], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG1], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG2], \ - tree_cons \ - (NULL_TREE, \ - builtin_types[(int) ARG3], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG4], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG5],\ - void_list_node)))))); + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + builtin_types[(int) ARG3], \ + builtin_types[(int) ARG4], \ + builtin_types[(int) ARG5], \ + NULL_TREE); #define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ ARG6) \ builtin_types[(int) ENUM] \ - = build_function_type \ - (builtin_types[(int) RETURN], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG1], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG2], \ - tree_cons \ - (NULL_TREE, \ - builtin_types[(int) ARG3], \ - tree_cons \ - (NULL_TREE, \ - builtin_types[(int) ARG4], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG5], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG6],\ - void_list_node))))))); + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + builtin_types[(int) ARG3], \ + builtin_types[(int) ARG4], \ + builtin_types[(int) ARG5], \ + builtin_types[(int) ARG6], \ + NULL_TREE); #define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ ARG6, ARG7) \ builtin_types[(int) ENUM] \ - = build_function_type \ - (builtin_types[(int) RETURN], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG1], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG2], \ - tree_cons \ - (NULL_TREE, \ - builtin_types[(int) ARG3], \ - tree_cons \ - (NULL_TREE, \ - builtin_types[(int) ARG4], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG5], \ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG6],\ - tree_cons (NULL_TREE, \ - builtin_types[(int) ARG6], \ - void_list_node)))))))); + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + builtin_types[(int) ARG3], \ + builtin_types[(int) ARG4], \ + builtin_types[(int) ARG5], \ + builtin_types[(int) ARG6], \ + builtin_types[(int) ARG7], \ + NULL_TREE); #define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \ builtin_types[(int) ENUM] \ - = build_function_type (builtin_types[(int) RETURN], NULL_TREE); + = build_varargs_function_type_list (builtin_types[(int) RETURN], \ + NULL_TREE); #define DEF_POINTER_TYPE(ENUM, TYPE) \ builtin_types[(int) ENUM] \ = build_pointer_type (builtin_types[(int) TYPE]); diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c new file mode 100644 index 00000000000..b6a74fd2cce --- /dev/null +++ b/gcc/fortran/frontend-passes.c @@ -0,0 +1,551 @@ +/* Pass manager for Fortran front end. + Copyright (C) 2010 Free Software Foundation, Inc. + Contributed by Thomas König. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +<http://www.gnu.org/licenses/>. */ + +#include "config.h" +#include "system.h" +#include "gfortran.h" +#include "arith.h" +#include "flags.h" +#include "dependency.h" + +/* Forward declarations. */ + +static void strip_function_call (gfc_expr *); +static void optimize_namespace (gfc_namespace *); +static void optimize_assignment (gfc_code *); +static bool optimize_op (gfc_expr *); +static bool optimize_equality (gfc_expr *, bool); + +/* Entry point - run all passes for a namespace. So far, only an + optimization pass is run. */ + +void +gfc_run_passes (gfc_namespace *ns) +{ + if (optimize) + optimize_namespace (ns); +} + +/* Callback for each gfc_code node invoked through gfc_code_walker + from optimize_namespace. */ + +static int +optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + if ((*c)->op == EXEC_ASSIGN) + optimize_assignment (*c); + return 0; +} + +/* Callback for each gfc_expr node invoked through gfc_code_walker + from optimize_namespace. */ + +static int +optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + if ((*e)->expr_type == EXPR_OP && optimize_op (*e)) + gfc_simplify_expr (*e, 0); + return 0; +} + +/* Optimize a namespace, including all contained namespaces. */ + +static void +optimize_namespace (gfc_namespace *ns) +{ + gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL); + + for (ns = ns->contained; ns; ns = ns->sibling) + optimize_namespace (ns); +} + +/* Replace code like + a = matmul(b,c) + d + with + a = matmul(b,c) ; a = a + d + where the array function is not elemental and not allocatable + and does not depend on the left-hand side. +*/ + +static bool +optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op) +{ + gfc_expr *e; + + e = *rhs; + if (e->expr_type == EXPR_OP) + { + switch (e->value.op.op) + { + /* Unary operators and exponentiation: Only look at a single + operand. */ + case INTRINSIC_NOT: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + case INTRINSIC_PARENTHESES: + case INTRINSIC_POWER: + if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op)) + return true; + break; + + default: + /* Binary operators. */ + if (optimize_binop_array_assignment (c, &e->value.op.op1, true)) + return true; + + if (optimize_binop_array_assignment (c, &e->value.op.op2, true)) + return true; + + break; + } + } + else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0 + && ! (e->value.function.esym + && (e->value.function.esym->attr.elemental + || e->value.function.esym->attr.allocatable)) + && ! (e->value.function.isym && e->value.function.isym->elemental)) + { + + gfc_code *n; + gfc_expr *new_expr; + + /* Insert a new assignment statement after the current one. */ + n = XCNEW (gfc_code); + n->op = EXEC_ASSIGN; + n->loc = c->loc; + n->next = c->next; + c->next = n; + + n->expr1 = gfc_copy_expr (c->expr1); + n->expr2 = c->expr2; + new_expr = gfc_copy_expr (c->expr1); + c->expr2 = e; + *rhs = new_expr; + + return true; + + } + + /* Nothing to optimize. */ + return false; +} + +/* Optimizations for an assignment. */ + +static void +optimize_assignment (gfc_code * c) +{ + gfc_expr *lhs, *rhs; + + lhs = c->expr1; + rhs = c->expr2; + + /* Optimize away a = trim(b), where a is a character variable. */ + + if (lhs->ts.type == BT_CHARACTER) + { + if (rhs->expr_type == EXPR_FUNCTION && + rhs->value.function.isym && + rhs->value.function.isym->id == GFC_ISYM_TRIM) + { + strip_function_call (rhs); + optimize_assignment (c); + return; + } + } + + if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0) + optimize_binop_array_assignment (c, &rhs, false); +} + + +/* Remove an unneeded function call, modifying the expression. + This replaces the function call with the value of its + first argument. The rest of the argument list is freed. */ + +static void +strip_function_call (gfc_expr *e) +{ + gfc_expr *e1; + gfc_actual_arglist *a; + + a = e->value.function.actual; + + /* We should have at least one argument. */ + gcc_assert (a->expr != NULL); + + e1 = a->expr; + + /* Free the remaining arglist, if any. */ + if (a->next) + gfc_free_actual_arglist (a->next); + + /* Graft the argument expression onto the original function. */ + *e = *e1; + gfc_free (e1); + +} + +/* Recursive optimization of operators. */ + +static bool +optimize_op (gfc_expr *e) +{ + gfc_intrinsic_op op = e->value.op.op; + + switch (op) + { + case INTRINSIC_EQ: + case INTRINSIC_EQ_OS: + case INTRINSIC_GE: + case INTRINSIC_GE_OS: + case INTRINSIC_LE: + case INTRINSIC_LE_OS: + return optimize_equality (e, true); + + case INTRINSIC_NE: + case INTRINSIC_NE_OS: + case INTRINSIC_GT: + case INTRINSIC_GT_OS: + case INTRINSIC_LT: + case INTRINSIC_LT_OS: + return optimize_equality (e, false); + + default: + break; + } + + return false; +} + +/* Optimize expressions for equality. */ + +static bool +optimize_equality (gfc_expr *e, bool equal) +{ + gfc_expr *op1, *op2; + bool change; + + op1 = e->value.op.op1; + op2 = e->value.op.op2; + + /* Strip off unneeded TRIM calls from string comparisons. */ + + change = false; + + if (op1->expr_type == EXPR_FUNCTION + && op1->value.function.isym + && op1->value.function.isym->id == GFC_ISYM_TRIM) + { + strip_function_call (op1); + change = true; + } + + if (op2->expr_type == EXPR_FUNCTION + && op2->value.function.isym + && op2->value.function.isym->id == GFC_ISYM_TRIM) + { + strip_function_call (op2); + change = true; + } + + if (change) + { + optimize_equality (e, equal); + return true; + } + + /* An expression of type EXPR_CONSTANT is only valid for scalars. */ + /* TODO: A scalar constant may be acceptable in some cases (the scalarizer + handles them well). However, there are also cases that need a non-scalar + argument. For example the any intrinsic. See PR 45380. */ + if (e->rank > 0) + return false; + + /* Check for direct comparison between identical variables. Don't compare + REAL or COMPLEX because of NaN checks. */ + if (op1->expr_type == EXPR_VARIABLE + && op2->expr_type == EXPR_VARIABLE + && op1->ts.type != BT_REAL && op2->ts.type != BT_REAL + && op1->ts.type != BT_COMPLEX && op2->ts.type !=BT_COMPLEX + && gfc_are_identical_variables (op1, op2)) + { + /* Replace the expression by a constant expression. The typespec + and where remains the way it is. */ + gfc_free (op1); + gfc_free (op2); + e->expr_type = EXPR_CONSTANT; + e->value.logical = equal; + return true; + } + return false; +} + +#define WALK_SUBEXPR(NODE) \ + do \ + { \ + result = gfc_expr_walker (&(NODE), exprfn, data); \ + if (result) \ + return result; \ + } \ + while (0) +#define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue + +/* Walk expression *E, calling EXPRFN on each expression in it. */ + +int +gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data) +{ + while (*e) + { + int walk_subtrees = 1; + gfc_actual_arglist *a; + int result = exprfn (e, &walk_subtrees, data); + if (result) + return result; + if (walk_subtrees) + switch ((*e)->expr_type) + { + case EXPR_OP: + WALK_SUBEXPR ((*e)->value.op.op1); + WALK_SUBEXPR_TAIL ((*e)->value.op.op2); + break; + case EXPR_FUNCTION: + for (a = (*e)->value.function.actual; a; a = a->next) + WALK_SUBEXPR (a->expr); + break; + case EXPR_COMPCALL: + case EXPR_PPC: + WALK_SUBEXPR ((*e)->value.compcall.base_object); + for (a = (*e)->value.compcall.actual; a; a = a->next) + WALK_SUBEXPR (a->expr); + break; + default: + break; + } + return 0; + } + return 0; +} + +#define WALK_SUBCODE(NODE) \ + do \ + { \ + result = gfc_code_walker (&(NODE), codefn, exprfn, data); \ + if (result) \ + return result; \ + } \ + while (0) + +/* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN + on each expression in it. If any of the hooks returns non-zero, that + value is immediately returned. If the hook sets *WALK_SUBTREES to 0, + no subcodes or subexpressions are traversed. */ + +int +gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, + void *data) +{ + for (; *c; c = &(*c)->next) + { + int walk_subtrees = 1; + int result = codefn (c, &walk_subtrees, data); + if (result) + return result; + if (walk_subtrees) + { + gfc_code *b; + switch ((*c)->op) + { + case EXEC_DO: + WALK_SUBEXPR ((*c)->ext.iterator->var); + WALK_SUBEXPR ((*c)->ext.iterator->start); + WALK_SUBEXPR ((*c)->ext.iterator->end); + WALK_SUBEXPR ((*c)->ext.iterator->step); + break; + case EXEC_SELECT: + WALK_SUBEXPR ((*c)->expr1); + for (b = (*c)->block; b; b = b->block) + { + gfc_case *cp; + for (cp = b->ext.case_list; cp; cp = cp->next) + { + WALK_SUBEXPR (cp->low); + WALK_SUBEXPR (cp->high); + } + WALK_SUBCODE (b->next); + } + continue; + case EXEC_ALLOCATE: + case EXEC_DEALLOCATE: + { + gfc_alloc *a; + for (a = (*c)->ext.alloc.list; a; a = a->next) + WALK_SUBEXPR (a->expr); + break; + } + case EXEC_FORALL: + { + gfc_forall_iterator *fa; + for (fa = (*c)->ext.forall_iterator; fa; fa = fa->next) + { + WALK_SUBEXPR (fa->var); + WALK_SUBEXPR (fa->start); + WALK_SUBEXPR (fa->end); + WALK_SUBEXPR (fa->stride); + } + break; + } + case EXEC_OPEN: + WALK_SUBEXPR ((*c)->ext.open->unit); + WALK_SUBEXPR ((*c)->ext.open->file); + WALK_SUBEXPR ((*c)->ext.open->status); + WALK_SUBEXPR ((*c)->ext.open->access); + WALK_SUBEXPR ((*c)->ext.open->form); + WALK_SUBEXPR ((*c)->ext.open->recl); + WALK_SUBEXPR ((*c)->ext.open->blank); + WALK_SUBEXPR ((*c)->ext.open->position); + WALK_SUBEXPR ((*c)->ext.open->action); + WALK_SUBEXPR ((*c)->ext.open->delim); + WALK_SUBEXPR ((*c)->ext.open->pad); + WALK_SUBEXPR ((*c)->ext.open->iostat); + WALK_SUBEXPR ((*c)->ext.open->iomsg); + WALK_SUBEXPR ((*c)->ext.open->convert); + WALK_SUBEXPR ((*c)->ext.open->decimal); + WALK_SUBEXPR ((*c)->ext.open->encoding); + WALK_SUBEXPR ((*c)->ext.open->round); + WALK_SUBEXPR ((*c)->ext.open->sign); + WALK_SUBEXPR ((*c)->ext.open->asynchronous); + WALK_SUBEXPR ((*c)->ext.open->id); + WALK_SUBEXPR ((*c)->ext.open->newunit); + break; + case EXEC_CLOSE: + WALK_SUBEXPR ((*c)->ext.close->unit); + WALK_SUBEXPR ((*c)->ext.close->status); + WALK_SUBEXPR ((*c)->ext.close->iostat); + WALK_SUBEXPR ((*c)->ext.close->iomsg); + break; + case EXEC_BACKSPACE: + case EXEC_ENDFILE: + case EXEC_REWIND: + case EXEC_FLUSH: + WALK_SUBEXPR ((*c)->ext.filepos->unit); + WALK_SUBEXPR ((*c)->ext.filepos->iostat); + WALK_SUBEXPR ((*c)->ext.filepos->iomsg); + break; + case EXEC_INQUIRE: + WALK_SUBEXPR ((*c)->ext.inquire->unit); + WALK_SUBEXPR ((*c)->ext.inquire->file); + WALK_SUBEXPR ((*c)->ext.inquire->iomsg); + WALK_SUBEXPR ((*c)->ext.inquire->iostat); + WALK_SUBEXPR ((*c)->ext.inquire->exist); + WALK_SUBEXPR ((*c)->ext.inquire->opened); + WALK_SUBEXPR ((*c)->ext.inquire->number); + WALK_SUBEXPR ((*c)->ext.inquire->named); + WALK_SUBEXPR ((*c)->ext.inquire->name); + WALK_SUBEXPR ((*c)->ext.inquire->access); + WALK_SUBEXPR ((*c)->ext.inquire->sequential); + WALK_SUBEXPR ((*c)->ext.inquire->direct); + WALK_SUBEXPR ((*c)->ext.inquire->form); + WALK_SUBEXPR ((*c)->ext.inquire->formatted); + WALK_SUBEXPR ((*c)->ext.inquire->unformatted); + WALK_SUBEXPR ((*c)->ext.inquire->recl); + WALK_SUBEXPR ((*c)->ext.inquire->nextrec); + WALK_SUBEXPR ((*c)->ext.inquire->blank); + WALK_SUBEXPR ((*c)->ext.inquire->position); + WALK_SUBEXPR ((*c)->ext.inquire->action); + WALK_SUBEXPR ((*c)->ext.inquire->read); + WALK_SUBEXPR ((*c)->ext.inquire->write); + WALK_SUBEXPR ((*c)->ext.inquire->readwrite); + WALK_SUBEXPR ((*c)->ext.inquire->delim); + WALK_SUBEXPR ((*c)->ext.inquire->encoding); + WALK_SUBEXPR ((*c)->ext.inquire->pad); + WALK_SUBEXPR ((*c)->ext.inquire->iolength); + WALK_SUBEXPR ((*c)->ext.inquire->convert); + WALK_SUBEXPR ((*c)->ext.inquire->strm_pos); + WALK_SUBEXPR ((*c)->ext.inquire->asynchronous); + WALK_SUBEXPR ((*c)->ext.inquire->decimal); + WALK_SUBEXPR ((*c)->ext.inquire->pending); + WALK_SUBEXPR ((*c)->ext.inquire->id); + WALK_SUBEXPR ((*c)->ext.inquire->sign); + WALK_SUBEXPR ((*c)->ext.inquire->size); + WALK_SUBEXPR ((*c)->ext.inquire->round); + break; + case EXEC_WAIT: + WALK_SUBEXPR ((*c)->ext.wait->unit); + WALK_SUBEXPR ((*c)->ext.wait->iostat); + WALK_SUBEXPR ((*c)->ext.wait->iomsg); + WALK_SUBEXPR ((*c)->ext.wait->id); + break; + case EXEC_READ: + case EXEC_WRITE: + WALK_SUBEXPR ((*c)->ext.dt->io_unit); + WALK_SUBEXPR ((*c)->ext.dt->format_expr); + WALK_SUBEXPR ((*c)->ext.dt->rec); + WALK_SUBEXPR ((*c)->ext.dt->advance); + WALK_SUBEXPR ((*c)->ext.dt->iostat); + WALK_SUBEXPR ((*c)->ext.dt->size); + WALK_SUBEXPR ((*c)->ext.dt->iomsg); + WALK_SUBEXPR ((*c)->ext.dt->id); + WALK_SUBEXPR ((*c)->ext.dt->pos); + WALK_SUBEXPR ((*c)->ext.dt->asynchronous); + WALK_SUBEXPR ((*c)->ext.dt->blank); + WALK_SUBEXPR ((*c)->ext.dt->decimal); + WALK_SUBEXPR ((*c)->ext.dt->delim); + WALK_SUBEXPR ((*c)->ext.dt->pad); + WALK_SUBEXPR ((*c)->ext.dt->round); + WALK_SUBEXPR ((*c)->ext.dt->sign); + WALK_SUBEXPR ((*c)->ext.dt->extra_comma); + break; + case EXEC_OMP_DO: + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SINGLE: + case EXEC_OMP_WORKSHARE: + case EXEC_OMP_END_SINGLE: + case EXEC_OMP_TASK: + if ((*c)->ext.omp_clauses) + { + WALK_SUBEXPR ((*c)->ext.omp_clauses->if_expr); + WALK_SUBEXPR ((*c)->ext.omp_clauses->num_threads); + WALK_SUBEXPR ((*c)->ext.omp_clauses->chunk_size); + } + break; + default: + break; + } + WALK_SUBEXPR ((*c)->expr1); + WALK_SUBEXPR ((*c)->expr2); + WALK_SUBEXPR ((*c)->expr3); + for (b = (*c)->block; b; b = b->block) + { + WALK_SUBEXPR (b->expr1); + WALK_SUBEXPR (b->expr2); + WALK_SUBCODE (b->next); + } + } + } + return 0; +} diff --git a/gcc/fortran/gfc-internals.texi b/gcc/fortran/gfc-internals.texi index 4e812103606..ed4c5ed3d66 100644 --- a/gcc/fortran/gfc-internals.texi +++ b/gcc/fortran/gfc-internals.texi @@ -1,7 +1,7 @@ \input texinfo @c -*-texinfo-*- @c %**start of header @setfilename gfc-internals.info -@set copyrights-gfortran 2007-2008 +@set copyrights-gfortran 2007, 2008, 2009, 2010 @include gcc-common.texi @@ -35,7 +35,7 @@ Copyright @copyright{} @value{copyrights-gfortran} Free Software Foundation, Inc. Permission is granted to copy, distribute and/or modify this document -under the terms of the GNU Free Documentation License, Version 1.2 or +under the terms of the GNU Free Documentation License, Version 1.3 or any later version published by the Free Software Foundation; with the Invariant Sections being ``Funding Free Software'', the Front-Cover Texts being (a) (see below), and with the Back-Cover Texts being (b) @@ -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 1f98824de75..947f1ff766e 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -34,7 +34,6 @@ along with GCC; see the file COPYING3. If not see #include "libgfortran.h" -#include "system.h" #include "intl.h" #include "coretypes.h" #include "input.h" @@ -158,7 +157,7 @@ expr_t; /* Array types. */ typedef enum { AS_EXPLICIT = 1, AS_ASSUMED_SHAPE, AS_DEFERRED, - AS_ASSUMED_SIZE, AS_UNKNOWN + AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_UNKNOWN } array_type; @@ -206,11 +205,12 @@ arith; /* Statements. */ typedef enum { - ST_ARITHMETIC_IF, ST_ALLOCATE, ST_ATTR_DECL, ST_BACKSPACE, - ST_BLOCK, ST_BLOCK_DATA, + ST_ARITHMETIC_IF, ST_ALLOCATE, ST_ATTR_DECL, ST_ASSOCIATE, + ST_BACKSPACE, ST_BLOCK, ST_BLOCK_DATA, ST_CALL, ST_CASE, ST_CLOSE, ST_COMMON, ST_CONTINUE, ST_CONTAINS, ST_CYCLE, ST_DATA, ST_DATA_DECL, ST_DEALLOCATE, ST_DO, ST_ELSE, ST_ELSEIF, - ST_ELSEWHERE, ST_END_BLOCK, ST_END_BLOCK_DATA, ST_ENDDO, ST_IMPLIED_ENDDO, + ST_ELSEWHERE, ST_END_ASSOCIATE, ST_END_BLOCK, ST_END_BLOCK_DATA, + ST_ENDDO, ST_IMPLIED_ENDDO, ST_END_FILE, ST_FINAL, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF, ST_END_INTERFACE, ST_END_MODULE, ST_END_PROGRAM, ST_END_SELECT, ST_END_SUBROUTINE, ST_END_WHERE, ST_END_TYPE, ST_ENTRY, ST_EQUIVALENCE, @@ -331,7 +331,11 @@ enum gfc_isym_id GFC_ISYM_ATAN, GFC_ISYM_ATAN2, GFC_ISYM_ATANH, + GFC_ISYM_BGE, + GFC_ISYM_BGT, GFC_ISYM_BIT_SIZE, + GFC_ISYM_BLE, + GFC_ISYM_BLT, GFC_ISYM_BTEST, GFC_ISYM_CEILING, GFC_ISYM_CHAR, @@ -348,12 +352,15 @@ 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, GFC_ISYM_DIM, GFC_ISYM_DOT_PRODUCT, GFC_ISYM_DPROD, + GFC_ISYM_DSHIFTL, + GFC_ISYM_DSHIFTR, GFC_ISYM_DTIME, GFC_ISYM_EOSHIFT, GFC_ISYM_EPSILON, @@ -361,6 +368,7 @@ enum gfc_isym_id GFC_ISYM_ERFC, GFC_ISYM_ERFC_SCALED, GFC_ISYM_ETIME, + GFC_ISYM_EXECUTE_COMMAND_LINE, GFC_ISYM_EXIT, GFC_ISYM_EXP, GFC_ISYM_EXPONENT, @@ -395,7 +403,9 @@ enum gfc_isym_id GFC_ISYM_HUGE, GFC_ISYM_HYPOT, GFC_ISYM_IACHAR, + GFC_ISYM_IALL, GFC_ISYM_IAND, + GFC_ISYM_IANY, GFC_ISYM_IARGC, GFC_ISYM_IBCLR, GFC_ISYM_IBITS, @@ -404,11 +414,13 @@ enum gfc_isym_id GFC_ISYM_IDATE, GFC_ISYM_IEOR, GFC_ISYM_IERRNO, + GFC_ISYM_IMAGE_INDEX, GFC_ISYM_INDEX, GFC_ISYM_INT, GFC_ISYM_INT2, GFC_ISYM_INT8, GFC_ISYM_IOR, + GFC_ISYM_IPARITY, GFC_ISYM_IRAND, GFC_ISYM_ISATTY, GFC_ISYM_IS_IOSTAT_END, @@ -420,9 +432,11 @@ enum gfc_isym_id GFC_ISYM_J0, GFC_ISYM_J1, GFC_ISYM_JN, + GFC_ISYM_JN2, GFC_ISYM_KILL, GFC_ISYM_KIND, GFC_ISYM_LBOUND, + GFC_ISYM_LCOBOUND, GFC_ISYM_LEADZ, GFC_ISYM_LEN, GFC_ISYM_LEN_TRIM, @@ -441,6 +455,8 @@ enum gfc_isym_id GFC_ISYM_LSTAT, GFC_ISYM_LTIME, GFC_ISYM_MALLOC, + GFC_ISYM_MASKL, + GFC_ISYM_MASKR, GFC_ISYM_MATMUL, GFC_ISYM_MAX, GFC_ISYM_MAXEXPONENT, @@ -449,6 +465,7 @@ enum gfc_isym_id GFC_ISYM_MCLOCK, GFC_ISYM_MCLOCK8, GFC_ISYM_MERGE, + GFC_ISYM_MERGE_BITS, GFC_ISYM_MIN, GFC_ISYM_MINEXPONENT, GFC_ISYM_MINLOC, @@ -460,12 +477,16 @@ enum gfc_isym_id GFC_ISYM_NEAREST, GFC_ISYM_NEW_LINE, GFC_ISYM_NINT, + GFC_ISYM_NORM2, GFC_ISYM_NOT, GFC_ISYM_NULL, GFC_ISYM_NUMIMAGES, GFC_ISYM_OR, GFC_ISYM_PACK, + GFC_ISYM_PARITY, GFC_ISYM_PERROR, + GFC_ISYM_POPCNT, + GFC_ISYM_POPPAR, GFC_ISYM_PRECISION, GFC_ISYM_PRESENT, GFC_ISYM_PRODUCT, @@ -488,6 +509,9 @@ enum gfc_isym_id GFC_ISYM_SECOND, GFC_ISYM_SET_EXPONENT, GFC_ISYM_SHAPE, + GFC_ISYM_SHIFTA, + GFC_ISYM_SHIFTL, + GFC_ISYM_SHIFTR, GFC_ISYM_SIGN, GFC_ISYM_SIGNAL, GFC_ISYM_SI_KIND, @@ -502,6 +526,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, @@ -509,6 +534,7 @@ enum gfc_isym_id GFC_ISYM_SYSTEM_CLOCK, GFC_ISYM_TAN, GFC_ISYM_TANH, + GFC_ISYM_THIS_IMAGE, GFC_ISYM_TIME, GFC_ISYM_TIME8, GFC_ISYM_TINY, @@ -518,6 +544,7 @@ enum gfc_isym_id GFC_ISYM_TRIM, GFC_ISYM_TTYNAM, GFC_ISYM_UBOUND, + GFC_ISYM_UCOBOUND, GFC_ISYM_UMASK, GFC_ISYM_UNLINK, GFC_ISYM_UNPACK, @@ -525,7 +552,8 @@ enum gfc_isym_id GFC_ISYM_XOR, GFC_ISYM_Y0, GFC_ISYM_Y1, - GFC_ISYM_YN + GFC_ISYM_YN, + GFC_ISYM_YN2 }; typedef enum gfc_isym_id gfc_isym_id; @@ -563,6 +591,22 @@ typedef enum } init_local_integer; +typedef enum +{ + GFC_FCOARRAY_NONE = 0, + GFC_FCOARRAY_SINGLE +} +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. */ @@ -651,10 +695,11 @@ extern const ext_attr_t ext_attr_list[]; typedef struct { /* Variable attributes. */ - unsigned allocatable:1, dimension:1, external:1, intrinsic:1, + unsigned allocatable:1, dimension:1, codimension:1, external:1, intrinsic:1, optional:1, pointer:1, target:1, value:1, volatile_:1, temporary:1, dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1, - implied_index:1, subref_array_pointer:1, proc_pointer:1, asynchronous:1; + implied_index:1, subref_array_pointer:1, proc_pointer:1, asynchronous:1, + contiguous:1; /* For CLASS containers, the pointer attribute is sometimes set internally even though it was not directly specified. In this case, keep the @@ -668,7 +713,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; @@ -680,7 +726,8 @@ typedef struct unsigned extension:8; /* extension level of a derived type. */ unsigned is_class:1; /* is a CLASS container. */ unsigned class_ok:1; /* is a CLASS object with correct attributes. */ - unsigned vtab:1; /* is a derived type vtab. */ + unsigned vtab:1; /* is a derived type vtab, pointed to by CLASS objects. */ + unsigned vtype:1; /* is a derived type of a vtab. */ /* These flags are both in the typespec and attribute. The attribute list is what gets read from/written to a module file. The typespec @@ -735,7 +782,7 @@ typedef struct possibly nested. zero_comp is true if the derived type has no component at all. */ unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1, - private_comp:1, zero_comp:1; + private_comp:1, zero_comp:1, coarray_comp:1; /* Attributes set by compiler extensions (!GCC$ ATTRIBUTES). */ unsigned ext_attr:EXT_ATTR_NUM; @@ -853,6 +900,7 @@ typedef struct { struct gfc_symbol *derived; /* For derived types only. */ gfc_charlen *cl; /* For character types only. */ + int pad; /* For hollerith types only. */ } u; @@ -867,7 +915,8 @@ gfc_typespec; typedef struct { int rank; /* A rank of zero means that a variable is a scalar. */ - array_type type; + int corank; + array_type type, cotype; struct gfc_expr *lower[GFC_MAX_DIMENSIONS], *upper[GFC_MAX_DIMENSIONS]; /* These two fields are used with the Cray Pointer extension. */ @@ -1189,6 +1238,9 @@ typedef struct gfc_symbol char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1]; /* Store a reference to the common_block, if this symbol is in one. */ struct gfc_common_head *common_block; + + /* Link to corresponding association-list if this is an associate name. */ + struct gfc_association_list *assoc; } gfc_symbol; @@ -1326,7 +1378,7 @@ typedef struct gfc_namespace struct gfc_code *code; /* Points to the equivalences set up in this namespace. */ - struct gfc_equiv *equiv; + struct gfc_equiv *equiv, *old_equiv; /* Points to the equivalence groups produced by trans_common. */ struct gfc_equiv_list *equiv_lists; @@ -1436,13 +1488,15 @@ extern gfc_interface_info current_interface; enum gfc_array_ref_dimen_type { - DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_UNKNOWN + DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_UNKNOWN }; typedef struct gfc_array_ref { ar_type type; int dimen; /* # of components in the reference */ + int codimen; + bool in_allocate; /* For coarray checks. */ locus where; gfc_array_spec *as; @@ -1507,7 +1561,7 @@ typedef struct gfc_intrinsic_arg char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_typespec ts; - int optional; + unsigned optional:1, value:1; ENUM_BITFIELD (sym_intent) intent:2; gfc_actual_arglist *actual; @@ -1601,17 +1655,6 @@ typedef struct gfc_intrinsic_sym gfc_intrinsic_sym; -typedef struct gfc_class_esym_list -{ - gfc_symbol *derived; - gfc_symbol *esym; - struct gfc_expr *hash_value; - struct gfc_class_esym_list *next; -} -gfc_class_esym_list; - -#define gfc_get_class_esym_list() XCNEW (gfc_class_esym_list) - /* Expression nodes. The expression node types deserve explanations, since the last couple can be easily misconstrued: @@ -1633,6 +1676,8 @@ gfc_class_esym_list; #define GFC_RND_MODE GMP_RNDN #define GFC_MPC_RND_MODE MPC_RNDNN +typedef splay_tree gfc_constructor_base; + typedef struct gfc_expr { expr_t expr_type; @@ -1650,23 +1695,21 @@ typedef struct gfc_expr locus where; - /* True if the expression is a call to a function that returns an array, - and if we have decided not to allocate temporary data for that array. - is_boz is true if the integer is regarded as BOZ bitpatten and is_snan + /* is_boz is true if the integer is regarded as BOZ bitpatten and is_snan denotes a signalling not-a-number. */ - unsigned int inline_noncopying_intrinsic : 1, is_boz : 1, is_snan : 1; + unsigned int is_boz : 1, is_snan : 1; /* Sometimes, when an error has been emitted, it is necessary to prevent it from recurring. */ unsigned int error : 1; - /* Mark and expression where a user operator has been substituted by + /* Mark an expression where a user operator has been substituted by a function call in interface.c(gfc_extend_expr). */ unsigned int user_operator : 1; - /* Used to quickly find a given constructor by its offset. */ - splay_tree con_by_offset; - + /* Mark an expression as being a MOLD argument of ALLOCATE. */ + unsigned int mold : 1; + /* If an expression comes from a Hollerith constant or compile-time evaluation of a transfer statement, it may have a prescribed target- memory representation, and these cannot always be backformed from @@ -1704,7 +1747,6 @@ typedef struct gfc_expr const char *name; /* Points to the ultimate name of the function */ gfc_intrinsic_sym *isym; gfc_symbol *esym; - gfc_class_esym_list *class_esym; } function; @@ -1735,7 +1777,7 @@ typedef struct gfc_expr } character; - struct gfc_constructor *constructor; + gfc_constructor_base constructor; } value; @@ -1796,6 +1838,7 @@ typedef struct unsigned int c_float : 1; unsigned int c_double : 1; unsigned int c_long_double : 1; + unsigned int c_float128 : 1; } gfc_real_info; @@ -1973,6 +2016,33 @@ typedef struct gfc_forall_iterator gfc_forall_iterator; +/* Linked list to store associations in an ASSOCIATE statement. */ + +typedef struct gfc_association_list +{ + struct gfc_association_list *next; + + /* Whether this is association to a variable that can be changed; otherwise, + it's association to an expression and the name may not be used as + lvalue. */ + unsigned variable:1; + + /* True if this struct is currently only linked to from a gfc_symbol rather + than as part of a real list in gfc_code->ext.block.assoc. This may + happen for SELECT TYPE temporaries and must be considered + for memory handling. */ + unsigned dangling:1; + + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symtree *st; /* Symtree corresponding to name. */ + locus where; + + gfc_expr *target; +} +gfc_association_list; +#define gfc_get_association_list() XCNEW (gfc_association_list) + + /* Executable statements that fill gfc_code structures. */ typedef enum { @@ -2025,6 +2095,13 @@ typedef struct gfc_code } alloc; + struct + { + gfc_namespace *ns; + gfc_association_list *assoc; + } + block; + gfc_open *open; gfc_close *close; gfc_filepos *filepos; @@ -2032,20 +2109,19 @@ typedef struct gfc_code gfc_wait *wait; gfc_dt *dt; gfc_forall_iterator *forall_iterator; - struct gfc_code *whichloop; + struct gfc_code *which_construct; int stop_code; gfc_entry_list *entry; gfc_omp_clauses *omp_clauses; const char *omp_name; gfc_namelist *omp_namelist; bool omp_bool; - gfc_namespace *ns; } ext; /* Points to additional structures required by statement */ - /* Backend_decl is used for cycle and break labels in do loops, and - probably for other constructs as well, once we translate them. */ - tree backend_decl; + /* Cycle and break labels in constructs. */ + tree cycle_label; + tree exit_label; } gfc_code; @@ -2103,6 +2179,7 @@ typedef struct int warn_aliasing; int warn_ampersand; int warn_conversion; + int warn_conversion_extra; int warn_implicit_interface; int warn_implicit_procedure; int warn_line_truncation; @@ -2114,6 +2191,7 @@ typedef struct int warn_character_truncation; int warn_array_temp; int warn_align_commons; + int warn_unused_dummy_argument; int max_errors; int flag_all_intrinsics; @@ -2157,6 +2235,7 @@ typedef struct int fpe; int rtcheck; + gfc_fcoarray coarray; int warn_std; int allow_std; @@ -2171,19 +2250,19 @@ extern gfc_option_t gfc_option; /* Constructor nodes for array and structure constructors. */ typedef struct gfc_constructor { + gfc_constructor_base base; + mpz_t offset; /* Offset within a constructor, used as + key within base. */ + gfc_expr *expr; gfc_iterator *iterator; locus where; - struct gfc_constructor *next; - struct + + union { - mpz_t offset; /* Record the offset of array element which appears in - data statement like "data a(5)/4/". */ - gfc_component *component; /* Record the component being initialized. */ + gfc_component *component; /* Record the component being initialized. */ } n; - mpz_t repeat; /* Record the repeat number of initial values in data - statement like "data a/5*10/". */ } gfc_constructor; @@ -2306,8 +2385,11 @@ void gfc_done_2 (void); int get_c_kind (const char *, CInteropKind_t *); /* options.c */ -unsigned int gfc_init_options (unsigned int, const char **); -int gfc_handle_option (size_t, const char *, int); +unsigned int gfc_option_lang_mask (void); +void gfc_init_options (unsigned int, + struct cl_decoded_option *); +bool gfc_handle_option (size_t, const char *, int, int, + const struct cl_option_handlers *); bool gfc_post_options (const char **); /* f95-lang.c */ @@ -2400,6 +2482,8 @@ void gfc_set_sym_referenced (gfc_symbol *); gfc_try gfc_add_attribute (symbol_attribute *, locus *); gfc_try gfc_add_ext_attribute (symbol_attribute *, ext_attr_id_t, locus *); gfc_try gfc_add_allocatable (symbol_attribute *, locus *); +gfc_try gfc_add_codimension (symbol_attribute *, const char *, locus *); +gfc_try gfc_add_contiguous (symbol_attribute *, const char *, locus *); gfc_try gfc_add_dimension (symbol_attribute *, const char *, locus *); gfc_try gfc_add_external (symbol_attribute *, locus *); gfc_try gfc_add_intrinsic (symbol_attribute *, locus *); @@ -2410,7 +2494,7 @@ gfc_try gfc_add_cray_pointee (symbol_attribute *, locus *); match gfc_mod_pointee_as (gfc_array_spec *); gfc_try gfc_add_protected (symbol_attribute *, const char *, locus *); gfc_try gfc_add_result (symbol_attribute *, const char *, locus *); -gfc_try gfc_add_save (symbol_attribute *, const char *, locus *); +gfc_try gfc_add_save (symbol_attribute *, save_state, const char *, locus *); gfc_try gfc_add_threadprivate (symbol_attribute *, const char *, locus *); gfc_try gfc_add_saved_common (symbol_attribute *, locus *); gfc_try gfc_add_target (symbol_attribute *, locus *); @@ -2469,7 +2553,9 @@ gfc_symtree *gfc_get_unique_symtree (gfc_namespace *); gfc_user_op *gfc_get_uop (const char *); gfc_user_op *gfc_find_uop (const char *, gfc_namespace *); void gfc_free_symbol (gfc_symbol *); +void gfc_release_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 **); @@ -2501,29 +2587,18 @@ void gfc_traverse_ns (gfc_namespace *, void (*)(gfc_symbol *)); void gfc_traverse_user_op (gfc_namespace *, void (*)(gfc_user_op *)); void gfc_save_all (gfc_namespace *); -void gfc_symbol_state (void); +void gfc_enforce_clean_symbol_state (void); void gfc_free_dt_list (void); gfc_gsymbol *gfc_get_gsymbol (const char *); gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *); -gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *, - gfc_array_spec **); -gfc_symbol *gfc_find_derived_vtab (gfc_symbol *); -gfc_typebound_proc* gfc_get_typebound_proc (void); +gfc_typebound_proc* gfc_get_typebound_proc (gfc_typebound_proc*); gfc_symbol* gfc_get_derived_super_type (gfc_symbol*); gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*); bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *); bool gfc_type_compatible (gfc_typespec *, gfc_typespec *); -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*, - const char*, bool, locus*); -gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*, - gfc_intrinsic_op, bool, - locus*); -gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*); void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *); void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *); @@ -2532,9 +2607,12 @@ void gfc_copy_formal_args_ppc (gfc_component *, gfc_symbol *); void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */ gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus); +gfc_namespace* gfc_find_proc_namespace (gfc_namespace*); + +bool gfc_is_associate_pointer (gfc_symbol*); -/* intrinsic.c */ -extern int gfc_init_expr; +/* intrinsic.c -- true if working in an init-expr, false otherwise. */ +extern bool gfc_init_expr_flag; /* Given a symbol that we have decided is intrinsic, mark it as such by placing it into a special module that is otherwise impossible to @@ -2570,6 +2648,7 @@ void gfc_free_forall_iterator (gfc_forall_iterator *); void gfc_free_alloc_list (gfc_alloc *); void gfc_free_namelist (gfc_namelist *); void gfc_free_equiv (gfc_equiv *); +void gfc_free_equiv_until (gfc_equiv *, gfc_equiv *); void gfc_free_data (gfc_data *); void gfc_free_case_list (gfc_case *); @@ -2588,8 +2667,8 @@ void gfc_free_actual_arglist (gfc_actual_arglist *); gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *); const char *gfc_extract_int (gfc_expr *, int *); bool is_subref_array (gfc_expr *); +bool gfc_is_simply_contiguous (gfc_expr *, bool); -void gfc_add_component_ref (gfc_expr *, const char *); gfc_expr *gfc_build_conversion (gfc_expr *); void gfc_free_ref_list (gfc_ref *); void gfc_type_convert_binary (gfc_expr *, int); @@ -2598,10 +2677,18 @@ gfc_try gfc_simplify_expr (gfc_expr *, int); int gfc_has_vector_index (gfc_expr *); gfc_expr *gfc_get_expr (void); +gfc_expr *gfc_get_array_expr (bt type, int kind, locus *); +gfc_expr *gfc_get_null_expr (locus *); +gfc_expr *gfc_get_operator_expr (locus *, gfc_intrinsic_op,gfc_expr *, gfc_expr *); +gfc_expr *gfc_get_structure_constructor_expr (bt, int, locus *); +gfc_expr *gfc_get_constant_expr (bt, int, locus *); +gfc_expr *gfc_get_character_expr (int, locus *, const char *, int len); +gfc_expr *gfc_get_int_expr (int, locus *, int); +gfc_expr *gfc_get_logical_expr (int, locus *, bool); +gfc_expr *gfc_get_iokind_expr (locus *, io_kind); + void gfc_free_expr (gfc_expr *); void gfc_replace_expr (gfc_expr *, gfc_expr *); -gfc_expr *gfc_int_expr (int); -gfc_expr *gfc_logical_expr (int, locus *); mpz_t *gfc_copy_shape (mpz_t *, int); mpz_t *gfc_copy_shape_excluding (mpz_t *, int, gfc_expr *); gfc_expr *gfc_copy_expr (gfc_expr *); @@ -2617,6 +2704,7 @@ gfc_try gfc_check_assign (gfc_expr *, gfc_expr *, int); gfc_try gfc_check_pointer_assign (gfc_expr *, gfc_expr *); gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *); +bool gfc_has_default_initializer (gfc_symbol *); gfc_expr *gfc_default_initializer (gfc_typespec *); gfc_expr *gfc_get_variable_expr (gfc_symtree *); @@ -2632,6 +2720,14 @@ 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 *); + +gfc_expr* gfc_build_intrinsic_call (const char*, locus, unsigned, ...); + + /* st.c */ extern gfc_code new_st; @@ -2640,6 +2736,7 @@ gfc_code *gfc_get_code (void); gfc_code *gfc_append_code (gfc_code *, gfc_code *); void gfc_free_statement (gfc_code *); void gfc_free_statements (gfc_code *); +void gfc_free_association_list (gfc_association_list *); /* resolve.c */ gfc_try gfc_resolve_expr (gfc_expr *); @@ -2660,6 +2757,8 @@ bool gfc_type_is_extensible (gfc_symbol *sym); /* array.c */ +gfc_iterator *gfc_copy_iterator (gfc_iterator *); + void gfc_free_array_spec (gfc_array_spec *); gfc_array_ref *gfc_copy_array_ref (gfc_array_ref *); @@ -2669,11 +2768,8 @@ gfc_try gfc_resolve_array_spec (gfc_array_spec *, int); int gfc_compare_array_spec (gfc_array_spec *, gfc_array_spec *); -gfc_expr *gfc_start_constructor (bt, int, locus *); -void gfc_append_constructor (gfc_expr *, gfc_expr *); -void gfc_free_constructor (gfc_constructor *); 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 *); @@ -2681,20 +2777,16 @@ gfc_try gfc_resolve_array_constructor (gfc_expr *); gfc_try gfc_check_constructor_type (gfc_expr *); gfc_try gfc_check_iter_variable (gfc_expr *); gfc_try gfc_check_constructor (gfc_expr *, gfc_try (*)(gfc_expr *)); -gfc_constructor *gfc_copy_constructor (gfc_constructor *); -gfc_expr *gfc_get_array_element (gfc_expr *, int); gfc_try gfc_array_size (gfc_expr *, mpz_t *); gfc_try gfc_array_dimen_size (gfc_expr *, int, mpz_t *); gfc_try gfc_array_ref_shape (gfc_array_ref *, mpz_t *); gfc_array_ref *gfc_find_array_ref (gfc_expr *); -void gfc_insert_constructor (gfc_expr *, gfc_constructor *); -gfc_constructor *gfc_get_constructor (void); tree gfc_conv_array_initializer (tree type, gfc_expr *); gfc_try spec_size (gfc_array_spec *, mpz_t *); gfc_try spec_dimen_size (gfc_array_spec *, int, mpz_t *); int gfc_is_compile_time_shape (gfc_array_spec *); -gfc_try gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *); +gfc_try gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *, mpz_t *); /* interface.c -- FIXME: some of these should be in symbol.c */ @@ -2717,6 +2809,7 @@ void gfc_set_current_interface_head (gfc_interface *); gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*); bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*); bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus); +int gfc_has_vector_subscript (gfc_expr*); /* io.c */ extern gfc_st_label format_asterisk; @@ -2764,12 +2857,39 @@ void gfc_dump_parse_tree (gfc_namespace *, FILE *); /* parse.c */ gfc_try gfc_parse_file (void); void gfc_global_used (gfc_gsymbol *, locus *); +gfc_namespace* gfc_build_block_ns (gfc_namespace *); /* 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*); +/* class.c */ +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 *); +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*, + const char*, bool, locus*); +gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*, + gfc_intrinsic_op, bool, + locus*); +gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*); + +#define CLASS_DATA(sym) sym->ts.u.derived->components + +/* frontend-passes.c */ + +void gfc_run_passes (gfc_namespace *); + +typedef int (*walk_code_fn_t) (gfc_code **, int *, void *); +typedef int (*walk_expr_fn_t) (gfc_expr **, int *, void *); + +int gfc_expr_walker (gfc_expr **, walk_expr_fn_t, void *); +int gfc_code_walker (gfc_code **, walk_code_fn_t, walk_expr_fn_t, void *); + #endif /* GCC_GFORTRAN_H */ diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 834e524c15c..10492f0d916 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -1,7 +1,7 @@ \input texinfo @c -*-texinfo-*- @c %**start of header @setfilename gfortran.info -@set copyrights-gfortran 1999-2008 +@set copyrights-gfortran 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 @include gcc-common.texi @@ -80,7 +80,7 @@ Copyright @copyright{} @value{copyrights-gfortran} Free Software Foundation, Inc. Permission is granted to copy, distribute and/or modify this document -under the terms of the GNU Free Documentation License, Version 1.2 or +under the terms of the GNU Free Documentation License, Version 1.3 or any later version published by the Free Software Foundation; with the Invariant Sections being ``Funding Free Software'', the Front-Cover Texts being (a) (see below), and with the Back-Cover Texts being (b) @@ -181,7 +181,7 @@ Part I: Invoking GNU Fortran Part II: Language Reference * Fortran 2003 and 2008 status:: Fortran 2003 and 2008 features supported by GNU Fortran. -* Compiler Characteristics:: KIND type parameters supported. +* Compiler Characteristics:: User-visible implementation details. * Mixed-Language Programming:: Interoperability with C * Extensions:: Language extensions implemented by GNU Fortran. * Intrinsic Procedures:: Intrinsic procedures supported by GNU Fortran. @@ -426,7 +426,7 @@ While CPP is the de-facto standard for preprocessing Fortran code, Part 3 of the Fortran 95 standard (ISO/IEC 1539-3:1998) defines Conditional Compilation, which is not widely used and not directly supported by the GNU Fortran compiler. You can use the program coco -to preprocess such files (@uref{http://users.erols.com/dnagle/coco.html}). +to preprocess such files (@uref{http://www.daniellnagle.com/coco.html}). @c --------------------------------------------------------------------- @@ -635,8 +635,8 @@ error is used. If the first letter is @samp{n}, @samp{N} or This environment variable controls where scratch files are created. If this environment variable is missing, -GNU Fortran searches for the environment variable @env{TMP}. If -this is also missing, the default is @file{/tmp}. +GNU Fortran searches for the environment variable @env{TMP}, then @env{TEMP}. +If these are missing, the default is @file{/tmp}. @node GFORTRAN_UNBUFFERED_ALL @section @env{GFORTRAN_UNBUFFERED_ALL}---Don't buffer I/O on all units @@ -962,14 +962,13 @@ about the current Fortran 2008 implementation status. @node Compiler Characteristics @chapter Compiler Characteristics -@c TODO: Formulate this introduction a little more generally once -@c there is more here than KIND type parameters. - -This chapter describes certain characteristics of the GNU Fortran compiler, -namely the KIND type parameter values supported. +This chapter describes certain characteristics of the GNU Fortran +compiler, that are not specified by the Fortran standard, but which +might in some way or another become visible to the programmer. @menu * KIND Type Parameters:: +* Internal representation of LOGICAL variables:: @end menu @@ -1013,6 +1012,32 @@ imaginary part are a real value of the given size). It is recommended to use the @code{SELECT_*_KIND} intrinsics instead of the concrete values. +@node Internal representation of LOGICAL variables +@section Internal representation of LOGICAL variables +@cindex logical, variable representation + +The Fortran standard does not specify how variables of @code{LOGICAL} +type are represented, beyond requiring that @code{LOGICAL} variables +of default kind have the same storage size as default @code{INTEGER} +and @code{REAL} variables. The GNU Fortran internal representation is +as follows. + +A @code{LOGICAL(KIND=N)} variable is represented as an +@code{INTEGER(KIND=N)} variable, however, with only two permissible +values: @code{1} for @code{.TRUE.} and @code{0} for +@code{.FALSE.}. Any other integer value results in undefined behavior. + +Note that for mixed-language programming using the +@code{ISO_C_BINDING} feature, there is a @code{C_BOOL} kind that can +be used to create @code{LOGICAL(KIND=C_BOOL)} variables which are +interoperable with the C99 _Bool type. The C99 _Bool type has an +internal representation described in the C99 standard, which is +identical to the above description, i.e. with 1 for true and 0 for +false being the only permissible values. Thus the internal +representation of @code{LOGICAL} variables in GNU Fortran is identical +to C99 _Bool, except for a possible difference in storage size +depending on the kind. + @c --------------------------------------------------------------------- @c Extensions @c --------------------------------------------------------------------- @@ -1490,10 +1515,10 @@ to Cray pointers and pointees. Pointees may not have the @code{ALLOCATABLE}, @code{INTENT}, @code{OPTIONAL}, @code{DUMMY}, @code{TARGET}, @code{INTRINSIC}, or @code{POINTER} attributes. Pointers may not have the @code{DIMENSION}, @code{POINTER}, @code{TARGET}, -@code{ALLOCATABLE}, @code{EXTERNAL}, or @code{INTRINSIC} attributes. -Pointees may not occur in more than one pointer statement. A pointee -cannot be a pointer. Pointees cannot occur in equivalence, common, or -data statements. +@code{ALLOCATABLE}, @code{EXTERNAL}, or @code{INTRINSIC} attributes, nor +may they be function results. Pointees may not occur in more than one +pointer statement. A pointee cannot be a pointer. Pointees cannot occur +in equivalence, common, or data statements. A Cray pointer may also point to a function or a subroutine. For example, the following excerpt is valid: @@ -1694,7 +1719,8 @@ code that uses them running with the GNU Fortran compiler. @c * TYPE and ACCEPT I/O Statements:: @c * .XOR. operator:: @c * CARRIAGECONTROL, DEFAULTFILE, DISPOSE and RECORDTYPE I/O specifiers:: -@c * Omitted arguments in procedure call: +@c * Omitted arguments in procedure call:: +* Alternate complex function syntax:: @end menu @@ -1847,12 +1873,12 @@ with the following: @smallexample c Variable declaration - CHARACTER(LEN=20) F + CHARACTER(LEN=20) FMT c c Other code here... c WRITE(FMT,'("(I", I0, ")")') N+1 - WRITE(6,FM) INT1 + WRITE(6,FMT) INT1 @end smallexample @noindent @@ -1869,6 +1895,18 @@ c @end smallexample +@node Alternate complex function syntax +@subsection Alternate complex function syntax +@cindex Complex function + +Some Fortran compilers, including @command{g77}, let the user declare +complex functions with the syntax @code{COMPLEX FUNCTION name*16()}, as +well as @code{COMPLEX*16 FUNCTION name()}. Both are non-standard, legacy +extensions. @command{gfortran} accepts the latter form, which is more +common, but not the former. + + + @c --------------------------------------------------------------------- @c Mixed-Language Programming @c --------------------------------------------------------------------- @@ -1895,10 +1933,11 @@ and their use is highly recommended. @menu * Intrinsic Types:: -* Further Interoperability of Fortran with C:: * Derived Types and struct:: * Interoperable Global Variables:: * Interoperable Subroutines and Functions:: +* Working with Pointers:: +* Further Interoperability of Fortran with C:: @end menu Since Fortran 2003 (ISO/IEC 1539-1:2004(E)) there is a @@ -2021,7 +2060,8 @@ matches the Fortran declaration integer(c_int) :: j @end smallexample -Note that pointer arguments also frequently need the @code{VALUE} attribute. +Note that pointer arguments also frequently need the @code{VALUE} attribute, +see @ref{Working with Pointers}. Strings are handled quite differently in C and Fortran. In C a string is a @code{NUL}-terminated array of characters while in Fortran each string @@ -2058,7 +2098,7 @@ literal has the right type; typically the default character kind and @code{c_char} are the same and thus @code{"Hello World"} is equivalent. However, the standard does not guarantee this. -The use of pointers is now illustrated using the C library +The use of strings is now further illustrated using the C library function @code{strncpy}, whose prototype is @smallexample @@ -2090,8 +2130,13 @@ example, we ignore the return value: end @end smallexample -C pointers are represented in Fortran via the special derived type -@code{type(c_ptr)}, with private components. Thus one needs to +The intrinsic procedures are described in @ref{Intrinsic Procedures}. + +@node Working with Pointers +@subsection Working with Pointers + +C pointers are represented in Fortran via the special opaque derived type +@code{type(c_ptr)} (with private components). Thus one needs to use intrinsic conversion procedures to convert from or to C pointers. For example, @@ -2109,14 +2154,131 @@ For example, @end smallexample When converting C to Fortran arrays, the one-dimensional @code{SHAPE} argument -has to be passed. Note: A pointer argument @code{void *} matches -@code{TYPE(C_PTR), VALUE} while @code{TYPE(C_PTR)} matches @code{void **}. +has to be passed. + +If a pointer is a dummy-argument of an interoperable procedure, it usually +has to be declared using the @code{VALUE} attribute. @code{void*} +matches @code{TYPE(C_PTR), VALUE}, while @code{TYPE(C_PTR)} alone +matches @code{void**}. Procedure pointers are handled analogously to pointers; the C type is @code{TYPE(C_FUNPTR)} and the intrinsic conversion procedures are -@code{C_F_PROC_POINTER} and @code{C_FUNLOC}. +@code{C_F_PROCPOINTER} and @code{C_FUNLOC}. -The intrinsic procedures are described in @ref{Intrinsic Procedures}. +Let's consider two examples of actually passing a procedure pointer from +C to Fortran and vice versa. Note that these examples are also very +similar to passing ordinary pointers between both languages. +First, consider this code in C: + +@smallexample +/* Procedure implemented in Fortran. */ +void get_values (void (*)(double)); + +/* Call-back routine we want called from Fortran. */ +void +print_it (double x) +@{ + printf ("Number is %f.\n", x); +@} + +/* Call Fortran routine and pass call-back to it. */ +void +foobar () +@{ + get_values (&print_it); +@} +@end smallexample + +A matching implementation for @code{get_values} in Fortran, that correctly +receives the procedure pointer from C and is able to call it, is given +in the following @code{MODULE}: + +@smallexample +MODULE m + IMPLICIT NONE + + ! Define interface of call-back routine. + ABSTRACT INTERFACE + SUBROUTINE callback (x) + USE, INTRINSIC :: ISO_C_BINDING + REAL(KIND=C_DOUBLE), INTENT(IN), VALUE :: x + END SUBROUTINE callback + END INTERFACE + +CONTAINS + + ! Define C-bound procedure. + SUBROUTINE get_values (cproc) BIND(C) + USE, INTRINSIC :: ISO_C_BINDING + TYPE(C_FUNPTR), INTENT(IN), VALUE :: cproc + + PROCEDURE(callback), POINTER :: proc + + ! Convert C to Fortran procedure pointer. + CALL C_F_PROCPOINTER (cproc, proc) + + ! Call it. + CALL proc (1.0_C_DOUBLE) + CALL proc (-42.0_C_DOUBLE) + CALL proc (18.12_C_DOUBLE) + END SUBROUTINE get_values + +END MODULE m +@end smallexample + +Next, we want to call a C routine that expects a procedure pointer argument +and pass it a Fortran procedure (which clearly must be interoperable!). +Again, the C function may be: + +@smallexample +int +call_it (int (*func)(int), int arg) +@{ + return func (arg); +@} +@end smallexample + +It can be used as in the following Fortran code: + +@smallexample +MODULE m + USE, INTRINSIC :: ISO_C_BINDING + IMPLICIT NONE + + ! Define interface of C function. + INTERFACE + INTEGER(KIND=C_INT) FUNCTION call_it (func, arg) BIND(C) + USE, INTRINSIC :: ISO_C_BINDING + TYPE(C_FUNPTR), INTENT(IN), VALUE :: func + INTEGER(KIND=C_INT), INTENT(IN), VALUE :: arg + END FUNCTION call_it + END INTERFACE + +CONTAINS + + ! Define procedure passed to C function. + ! It must be interoperable! + INTEGER(KIND=C_INT) FUNCTION double_it (arg) BIND(C) + INTEGER(KIND=C_INT), INTENT(IN), VALUE :: arg + double_it = arg + arg + END FUNCTION double_it + + ! Call C function. + SUBROUTINE foobar () + TYPE(C_FUNPTR) :: cproc + INTEGER(KIND=C_INT) :: i + + ! Get C procedure pointer. + cproc = C_FUNLOC (double_it) + + ! Use it. + DO i = 1_C_INT, 10_C_INT + PRINT *, call_it (cproc, i) + END DO + END SUBROUTINE foobar + +END MODULE m +@end smallexample @node Further Interoperability of Fortran with C @subsection Further Interoperability of Fortran with C @@ -2297,9 +2459,10 @@ if e.g. an input-output edit descriptor is invalid in a given standard. Possible values are (bitwise or-ed) @code{GFC_STD_F77} (1), @code{GFC_STD_F95_OBS} (2), @code{GFC_STD_F95_DEL} (4), @code{GFC_STD_F95} (8), @code{GFC_STD_F2003} (16), @code{GFC_STD_GNU} (32), -@code{GFC_STD_LEGACY} (64), and @code{GFC_STD_F2008} (128). -Default: @code{GFC_STD_F95_OBS | GFC_STD_F95_DEL | GFC_STD_F2003 -| GFC_STD_F2008 | GFC_STD_F95 | GFC_STD_F77 | GFC_STD_GNU | GFC_STD_LEGACY}. +@code{GFC_STD_LEGACY} (64), @code{GFC_STD_F2008} (128), and +@code{GFC_STD_F2008_OBS} (256). Default: @code{GFC_STD_F95_OBS +| GFC_STD_F95_DEL | GFC_STD_F95 | GFC_STD_F2003 | GFC_STD_F2008 +| GFC_STD_F2008_OBS | GFC_STD_F77 | GFC_STD_GNU | GFC_STD_LEGACY}. @item @var{option}[1] @tab Standard-warning flag; prints a warning to standard error. Default: @code{GFC_STD_F95_DEL | GFC_STD_LEGACY}. @item @var{option}[2] @tab If non zero, enable pedantic checking. @@ -2614,9 +2777,6 @@ J3 Fortran 95 standard. User-specified alignment rules for structures. @item -Flag to generate @code{Makefile} info. - -@item Automatically extend single precision constants to double. @item diff --git a/gcc/fortran/gfortranspec.c b/gcc/fortran/gfortranspec.c index 8f860a6b2d7..4220280eb22 100644 --- a/gcc/fortran/gfortranspec.c +++ b/gcc/fortran/gfortranspec.c @@ -48,163 +48,62 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gcc.h" +#include "opts.h" -#include "coretypes.h" #include "tm.h" #include "intl.h" #ifndef MATH_LIBRARY -#define MATH_LIBRARY "-lm" +#define MATH_LIBRARY "m" #endif #ifndef FORTRAN_LIBRARY -#define FORTRAN_LIBRARY "-lgfortran" -#endif - -#ifdef HAVE_LD_STATIC_DYNAMIC -#define ADD_ARG_LIBGFORTRAN(arg) \ - { \ - if (static_lib && !static_linking) \ - append_arg ("-Wl,-Bstatic"); \ - append_arg (arg); \ - if (static_lib && !static_linking) \ - append_arg ("-Wl,-Bdynamic"); \ - } -#else -#define ADD_ARG_LIBGFORTRAN(arg) append_arg (arg); +#define FORTRAN_LIBRARY "gfortran" #endif - -/* Options this driver needs to recognize, not just know how to - skip over. */ -typedef enum -{ - OPTION_b, /* Aka --prefix. */ - OPTION_B, /* Aka --target. */ - OPTION_c, /* Aka --compile. */ - OPTION_E, /* Aka --preprocess. */ - OPTION_help, /* --help. */ - OPTION_i, /* -imacros, -include, -include-*. */ - OPTION_l, - OPTION_L, /* Aka --library-directory. */ - OPTION_nostdlib, /* Aka --no-standard-libraries, or - -nodefaultlibs. */ - OPTION_o, /* Aka --output. */ - OPTION_S, /* Aka --assemble. */ - OPTION_static, /* -static. */ - OPTION_static_libgfortran, /* -static-libgfortran. */ - OPTION_syntax_only, /* -fsyntax-only. */ - OPTION_v, /* Aka --verbose. */ - OPTION_version, /* --version. */ - OPTION_V, /* Aka --use-version. */ - OPTION_x, /* Aka --language. */ - OPTION_ /* Unrecognized or unimportant. */ -} -Option; - /* The original argument list and related info is copied here. */ -static int g77_xargc; -static const char *const *g77_xargv; -static void lookup_option (Option *, int *, const char **, const char *); -static void append_arg (const char *); +static unsigned int g77_xargc; +static const struct cl_decoded_option *g77_x_decoded_options; +static void append_arg (const struct cl_decoded_option *); /* The new argument list will be built here. */ -static int g77_newargc; -static const char **g77_newargv; +static unsigned int g77_newargc; +static struct cl_decoded_option *g77_new_decoded_options; -/* --- This comes from gcc.c (2.8.1) verbatim: */ +/* Return whether strings S1 and S2 are both NULL or both the same + string. */ -/* This defines which switch letters take arguments. */ - -#ifndef SWITCH_TAKES_ARG -#define SWITCH_TAKES_ARG(CHAR) DEFAULT_SWITCH_TAKES_ARG(CHAR) -#endif - -/* This defines which multi-letter switches take arguments. */ - -#ifndef WORD_SWITCH_TAKES_ARG -#define WORD_SWITCH_TAKES_ARG(STR) DEFAULT_WORD_SWITCH_TAKES_ARG (STR) -#endif - -/* --- End of verbatim. */ - -/* Assumes text[0] == '-'. Returns number of argv items that belong to - (and follow) this one, an option id for options important to the - caller, and a pointer to the first char of the arg, if embedded (else - returns NULL, meaning no arg or it's the next argv). +static bool +strings_same (const char *s1, const char *s2) +{ + return s1 == s2 || (s1 != NULL && s2 != NULL && strcmp (s1, s2) == 0); +} - Note that this also assumes gcc.c's pass converting long options - to short ones, where available, has already been run. */ +/* Return whether decoded option structures OPT1 and OPT2 are the + same. */ -static void -lookup_option (Option *xopt, int *xskip, const char **xarg, const char *text) +static bool +options_same (const struct cl_decoded_option *opt1, + const struct cl_decoded_option *opt2) { - Option opt = OPTION_; - int skip; - const char *arg = NULL; - - if ((skip = SWITCH_TAKES_ARG (text[1]))) - skip -= (text[2] != '\0'); /* See gcc.c. */ - - if (text[1] == 'B') - opt = OPTION_B, skip = (text[2] == '\0'), arg = text + 2; - else if (text[1] == 'b') - opt = OPTION_b, skip = (text[2] == '\0'), arg = text + 2; - else if ((text[1] == 'c') && (text[2] == '\0')) - opt = OPTION_c, skip = 0; - else if ((text[1] == 'E') && (text[2] == '\0')) - opt = OPTION_E, skip = 0; - else if (text[1] == 'i') - opt = OPTION_i, skip = 0; - else if (text[1] == 'l') - opt = OPTION_l; - else if (text[1] == 'L') - opt = OPTION_L, arg = text + 2; - else if (text[1] == 'o') - opt = OPTION_o; - else if ((text[1] == 'S') && (text[2] == '\0')) - opt = OPTION_S, skip = 0; - else if (text[1] == 'V') - opt = OPTION_V, skip = (text[2] == '\0'); - else if ((text[1] == 'v') && (text[2] == '\0')) - opt = OPTION_v, skip = 0; - else if (text[1] == 'x') - opt = OPTION_x, arg = text + 2; - else if (text[1] == 'J') - ; - else - { - if ((skip = WORD_SWITCH_TAKES_ARG (text + 1)) != 0) /* See gcc.c. */ - ; - else if (!strcmp (text, "-fhelp")) /* Really --help!! */ - opt = OPTION_help; - else if (!strcmp (text, "-nostdlib") - || !strcmp (text, "-nodefaultlibs")) - opt = OPTION_nostdlib; - else if (!strcmp (text, "-fsyntax-only")) - opt = OPTION_syntax_only; - else if (!strcmp (text, "-static-libgfortran")) - opt = OPTION_static_libgfortran; - else if (!strcmp (text, "-fversion")) /* Really --version!! */ - opt = OPTION_version; - else if (!strcmp (text, "-Xlinker") || !strcmp (text, "-specs")) - skip = 1; - else - skip = 0; - } - - if (xopt != NULL) - *xopt = opt; - if (xskip != NULL) - *xskip = skip; - if (xarg != NULL) - { - if ((arg != NULL) && (arg[0] == '\0')) - *xarg = NULL; - else - *xarg = arg; - } + return (opt1->opt_index == opt2->opt_index + && strings_same (opt1->arg, opt2->arg) + && strings_same (opt1->orig_option_with_args_text, + opt2->orig_option_with_args_text) + && strings_same (opt1->canonical_option[0], + opt2->canonical_option[0]) + && strings_same (opt1->canonical_option[1], + opt2->canonical_option[1]) + && strings_same (opt1->canonical_option[2], + opt2->canonical_option[2]) + && strings_same (opt1->canonical_option[3], + opt2->canonical_option[3]) + && (opt1->canonical_option_num_elements + == opt2->canonical_option_num_elements) + && opt1->value == opt2->value + && opt1->errors == opt2->errors); } /* Append another argument to the list being built. As long as it is @@ -212,52 +111,78 @@ lookup_option (Option *xopt, int *xskip, const char **xarg, const char *text) the new arg count. Otherwise allocate a new list, etc. */ static void -append_arg (const char *arg) +append_arg (const struct cl_decoded_option *arg) { - static int newargsize; + static unsigned int newargsize; #if 0 fprintf (stderr, "`%s'\n", arg); #endif - if (g77_newargv == g77_xargv + if (g77_new_decoded_options == g77_x_decoded_options && g77_newargc < g77_xargc - && (arg == g77_xargv[g77_newargc] - || !strcmp (arg, g77_xargv[g77_newargc]))) + && options_same (arg, &g77_x_decoded_options[g77_newargc])) { ++g77_newargc; return; /* Nothing new here. */ } - if (g77_newargv == g77_xargv) + if (g77_new_decoded_options == g77_x_decoded_options) { /* Make new arglist. */ - int i; + unsigned int i; newargsize = (g77_xargc << 2) + 20; /* This should handle all. */ - g77_newargv = (const char **) xmalloc (newargsize * sizeof (char *)); + g77_new_decoded_options = XNEWVEC (struct cl_decoded_option, newargsize); /* Copy what has been done so far. */ for (i = 0; i < g77_newargc; ++i) - g77_newargv[i] = g77_xargv[i]; + g77_new_decoded_options[i] = g77_x_decoded_options[i]; } if (g77_newargc == newargsize) - fatal ("overflowed output arg list for '%s'", arg); + fatal_error ("overflowed output arg list for %qs", + arg->orig_option_with_args_text); - g77_newargv[g77_newargc++] = arg; + g77_new_decoded_options[g77_newargc++] = *arg; +} + +/* Append an option described by OPT_INDEX, ARG and VALUE to the list + being built. */ +static void +append_option (size_t opt_index, const char *arg, int value) +{ + struct cl_decoded_option decoded; + + generate_option (opt_index, arg, value, CL_DRIVER, &decoded); + append_arg (&decoded); +} + +/* Append a libgfortran argument to the list being built. If + FORCE_STATIC, ensure the library is linked statically. */ + +static void +add_arg_libgfortran (bool force_static ATTRIBUTE_UNUSED) +{ +#ifdef HAVE_LD_STATIC_DYNAMIC + if (force_static) + append_option (OPT_Wl_, "-Bstatic", 1); +#endif + append_option (OPT_l, FORTRAN_LIBRARY, 1); +#ifdef HAVE_LD_STATIC_DYNAMIC + if (force_static) + append_option (OPT_Wl_, "-Bdynamic", 1); +#endif } void -lang_specific_driver (int *in_argc, const char *const **in_argv, +lang_specific_driver (struct cl_decoded_option **in_decoded_options, + unsigned int *in_decoded_options_count, int *in_added_libraries ATTRIBUTE_UNUSED) { - int argc = *in_argc; - const char *const *argv = *in_argv; - int i; + unsigned int argc = *in_decoded_options_count; + struct cl_decoded_option *decoded_options = *in_decoded_options; + unsigned int i; int verbose = 0; - Option opt; - int skip; - const char *arg; /* This will be NULL if we encounter a situation where we should not link in libf2c. */ @@ -275,8 +200,8 @@ lang_specific_driver (int *in_argc, const char *const **in_argv, /* By default, we throw on the math library if we have one. */ int need_math = (MATH_LIBRARY[0] != '\0'); - /* Whether we should link a static libgfortran. */ - int static_lib = 0; + /* Whether we should link a static libgfortran. */ + int static_lib = 0; /* Whether we need to link statically. */ int static_linking = 0; @@ -288,86 +213,65 @@ lang_specific_driver (int *in_argc, const char *const **in_argv, #if 0 fprintf (stderr, "Incoming:"); for (i = 0; i < argc; i++) - fprintf (stderr, " %s", argv[i]); + fprintf (stderr, " %s", decoded_options[i].orig_option_with_args_text); fprintf (stderr, "\n"); #endif g77_xargc = argc; - g77_xargv = argv; + g77_x_decoded_options = decoded_options; g77_newargc = 0; - g77_newargv = CONST_CAST2 (const char **, const char *const *, argv); + g77_new_decoded_options = decoded_options; /* First pass through arglist. If -nostdlib or a "turn-off-linking" option is anywhere in the command line, don't do any library-option processing (except - relating to -x). Also, if -v is specified, but no other options - that do anything special (allowing -V version, etc.), remember - to add special stuff to make gcc command actually invoke all - the different phases of the compilation process so all the version - numbers can be seen. - - Also, here is where all problems with missing arguments to options - are caught. If this loop is exited normally, it means all options - have the appropriate number of arguments as far as the rest of this - program is concerned. */ + relating to -x). */ for (i = 1; i < argc; ++i) { - if ((argv[i][0] == '+') && (argv[i][1] == 'e')) - { - continue; - } - - if ((argv[i][0] != '-') || (argv[i][1] == '\0')) + switch (decoded_options[i].opt_index) { + case OPT_SPECIAL_input_file: ++n_infiles; continue; - } - - lookup_option (&opt, &skip, NULL, argv[i]); - switch (opt) - { - case OPTION_nostdlib: - case OPTION_c: - case OPTION_S: - case OPTION_syntax_only: - case OPTION_E: + case OPT_nostdlib: + case OPT_nodefaultlibs: + case OPT_c: + case OPT_S: + case OPT_fsyntax_only: + case OPT_E: /* These options disable linking entirely or linking of the standard libraries. */ library = 0; break; - case OPTION_static_libgfortran: + case OPT_static_libgfortran: +#ifdef HAVE_LD_STATIC_DYNAMIC static_lib = 1; +#endif break; - case OPTION_static: + case OPT_static: +#ifdef HAVE_LD_STATIC_DYNAMIC static_linking = 1; +#endif + break; - case OPTION_l: + case OPT_l: ++n_infiles; break; - case OPTION_o: + case OPT_o: ++n_outfiles; break; - case OPTION_v: + case OPT_v: verbose = 1; break; - case OPTION_b: - case OPTION_B: - case OPTION_L: - case OPTION_i: - case OPTION_V: - /* These options are useful in conjunction with -v to get - appropriate version info. */ - break; - - case OPTION_version: + case OPT_fversion: printf ("GNU Fortran %s%s\n", pkgversion_string, version_string); printf ("Copyright %s 2010 Free Software Foundation, Inc.\n\n", _("(C)")); @@ -378,7 +282,7 @@ For more information about these matters, see the file named COPYING\n\n")); exit (0); break; - case OPTION_help: + case OPT_fhelp: /* Let gcc.c handle this, as it has a really cool facility for handling --help and --verbose --help. */ return; @@ -386,18 +290,10 @@ For more information about these matters, see the file named COPYING\n\n")); default: break; } - - /* This is the one place we check for missing arguments in the - program. */ - - if (i + skip < argc) - i += skip; - else - fatal ("argument to '%s' missing", argv[i]); } if ((n_outfiles != 0) && (n_infiles == 0)) - fatal ("no input files; unwilling to write output files"); + fatal_error ("no input files; unwilling to write output files"); /* If there are no input files, no need for the library. */ if (n_infiles == 0) @@ -405,80 +301,50 @@ For more information about these matters, see the file named COPYING\n\n")); /* Second pass through arglist, transforming arguments as appropriate. */ - append_arg (argv[0]); /* Start with command name, of course. */ + append_arg (&decoded_options[0]); /* Start with command name, of course. */ for (i = 1; i < argc; ++i) { - if (argv[i][0] == '\0') + if (decoded_options[i].errors & CL_ERR_MISSING_ARG) { - append_arg (argv[i]); /* Interesting. Just append as is. */ + append_arg (&decoded_options[i]); continue; } - if ((argv[i][0] == '-') && (argv[i][1] == 'M')) + if (decoded_options[i].opt_index == OPT_SPECIAL_input_file + && decoded_options[i].arg[0] == '\0') { - char *p; - - fprintf (stderr, _("Warning: Using -M <directory> is deprecated, " - "use -J instead\n")); - if (argv[i][2] == '\0') - { - if (i+1 < argc) - { - p = XNEWVEC (char, strlen (argv[i + 1]) + 3); - p[0] = '-'; - p[1] = 'J'; - strcpy (&p[2], argv[i + 1]); - i++; - } - else - fatal ("argument to '%s' missing", argv[i]); - } - else - { - p = XNEWVEC (char, strlen (argv[i]) + 1); - p[0] = '-'; - p[1] = 'J'; - strcpy (&p[2], argv[i] + 2); - } - append_arg (p); + /* Interesting. Just append as is. */ + append_arg (&decoded_options[i]); continue; } - if ((argv[i][0] == '-') && (argv[i][1] != 'l')) + if (decoded_options[i].opt_index != OPT_l + && (decoded_options[i].opt_index != OPT_SPECIAL_input_file + || strcmp (decoded_options[i].arg, "-") == 0)) { /* Not a filename or library. */ if (saw_library == 1 && need_math) /* -l<library>. */ - append_arg (MATH_LIBRARY); + append_option (OPT_l, MATH_LIBRARY, 1); saw_library = 0; - lookup_option (&opt, &skip, &arg, argv[i]); - - if (argv[i][1] == '\0') + if (decoded_options[i].opt_index == OPT_SPECIAL_input_file) { - append_arg (argv[i]); /* "-" == Standard input. */ + append_arg (&decoded_options[i]); /* "-" == Standard input. */ continue; } - if (opt == OPTION_x) + if (decoded_options[i].opt_index == OPT_x) { /* Track input language. */ - const char *lang; - - if (arg == NULL) - lang = argv[i + 1]; - else - lang = arg; + const char *lang = decoded_options[i].arg; saw_speclang = (strcmp (lang, "none") != 0); } - append_arg (argv[i]); - - for (; skip != 0; --skip) - append_arg (argv[++i]); + append_arg (&decoded_options[i]); continue; } @@ -489,47 +355,47 @@ For more information about these matters, see the file named COPYING\n\n")); saw_library = 0; /* -xfoo currently active. */ else { /* -lfoo or filename. */ - if (strcmp (argv[i], MATH_LIBRARY) == 0) + if (decoded_options[i].opt_index == OPT_l + && strcmp (decoded_options[i].arg, MATH_LIBRARY) == 0) { if (saw_library == 1) saw_library = 2; /* -l<library> -lm. */ else - { - ADD_ARG_LIBGFORTRAN (FORTRAN_LIBRARY); - } + add_arg_libgfortran (static_lib && !static_linking); } - else if (strcmp (argv[i], FORTRAN_LIBRARY) == 0) + else if (decoded_options[i].opt_index == OPT_l + && strcmp (decoded_options[i].arg, FORTRAN_LIBRARY) == 0) { saw_library = 1; /* -l<library>. */ - ADD_ARG_LIBGFORTRAN (argv[i]); + add_arg_libgfortran (static_lib && !static_linking); continue; } else { /* Other library, or filename. */ if (saw_library == 1 && need_math) - append_arg (MATH_LIBRARY); + append_option (OPT_l, MATH_LIBRARY, 1); saw_library = 0; } } - append_arg (argv[i]); + append_arg (&decoded_options[i]); } - /* Append `-lg2c -lm' as necessary. */ + /* Append `-lgfortran -lm' as necessary. */ if (library) { /* Doing a link and no -nostdlib. */ if (saw_speclang) - append_arg ("-xnone"); + append_option (OPT_x, "none", 1); switch (saw_library) { case 0: - ADD_ARG_LIBGFORTRAN (library); + add_arg_libgfortran (static_lib && !static_linking); /* Fall through. */ case 1: if (need_math) - append_arg (MATH_LIBRARY); + append_option (OPT_l, MATH_LIBRARY, 1); default: break; } @@ -538,30 +404,30 @@ For more information about these matters, see the file named COPYING\n\n")); #ifdef ENABLE_SHARED_LIBGCC if (library) { - int i; + unsigned int i; for (i = 1; i < g77_newargc; i++) - if (g77_newargv[i][0] == '-') - if (strcmp (g77_newargv[i], "-static-libgcc") == 0 - || strcmp (g77_newargv[i], "-static") == 0) - break; + if (g77_new_decoded_options[i].opt_index == OPT_static_libgcc + || g77_new_decoded_options[i].opt_index == OPT_static) + break; if (i == g77_newargc) - append_arg ("-shared-libgcc"); + append_option (OPT_shared_libgcc, NULL, 1); } #endif - if (verbose && g77_newargv != g77_xargv) + if (verbose && g77_new_decoded_options != g77_x_decoded_options) { fprintf (stderr, _("Driving:")); for (i = 0; i < g77_newargc; i++) - fprintf (stderr, " %s", g77_newargv[i]); + fprintf (stderr, " %s", + g77_new_decoded_options[i].orig_option_with_args_text); fprintf (stderr, "\n"); } - *in_argc = g77_newargc; - *in_argv = g77_newargv; + *in_decoded_options_count = g77_newargc; + *in_decoded_options = g77_new_decoded_options; } diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 5b01af91f98..044ccd639f2 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1129,8 +1129,8 @@ check_interface1 (gfc_interface *p, gfc_interface *q0, if (p->sym->name == q->sym->name && p->sym->module == q->sym->module) continue; - if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag, 0, - NULL, 0)) + if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag, + 0, NULL, 0)) { if (referenced) gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L", @@ -1368,6 +1368,11 @@ compare_pointer (gfc_symbol *formal, gfc_expr *actual) if (formal->attr.pointer) { attr = gfc_expr_attr (actual); + + /* Fortran 2008 allows non-pointer actual arguments. */ + if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN) + return 2; + if (!attr.pointer) return 0; } @@ -1376,6 +1381,30 @@ compare_pointer (gfc_symbol *formal, gfc_expr *actual) } +/* Emit clear error messages for rank mismatch. */ + +static void +argument_rank_mismatch (const char *name, locus *where, + int rank1, int rank2) +{ + if (rank1 == 0) + { + gfc_error ("Rank mismatch in argument '%s' at %L " + "(scalar and rank-%d)", name, where, rank2); + } + else if (rank2 == 0) + { + gfc_error ("Rank mismatch in argument '%s' at %L " + "(rank-%d and scalar)", name, where, rank1); + } + else + { + gfc_error ("Rank mismatch in argument '%s' at %L " + "(rank-%d and rank-%d)", name, where, rank1, rank2); + } +} + + /* Given a symbol of a formal argument list and an expression, see if the two are compatible as arguments. Returns nonzero if compatible, zero if not compatible. */ @@ -1399,6 +1428,11 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c) return 1; + if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED) + /* Make sure the vtab symbol is present when + the module variables are generated. */ + gfc_find_derived_vtab (actual->ts.u.derived); + if (actual->ts.type == BT_PROCEDURE) { char err[200]; @@ -1435,7 +1469,18 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return 1; } + /* F2008, C1241. */ + if (formal->attr.pointer && formal->attr.contiguous + && !gfc_is_simply_contiguous (actual, true)) + { + if (where) + gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L " + "must be simply contigous", formal->name, &actual->where); + return 0; + } + if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) + && actual->ts.type != BT_HOLLERITH && !gfc_compare_types (&formal->ts, &actual->ts)) { if (where) @@ -1445,6 +1490,93 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return 0; } + if (formal->attr.codimension) + { + gfc_ref *last = NULL; + + if (actual->expr_type != EXPR_VARIABLE + || (actual->ref == NULL + && !actual->symtree->n.sym->attr.codimension)) + { + if (where) + gfc_error ("Actual argument to '%s' at %L must be a coarray", + formal->name, &actual->where); + return 0; + } + + for (ref = actual->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY && ref->u.ar.codimen != 0) + { + if (where) + gfc_error ("Actual argument to '%s' at %L must be a coarray " + "and not coindexed", formal->name, &ref->u.ar.where); + return 0; + } + if (ref->type == REF_ARRAY && ref->u.ar.as->corank + && ref->u.ar.type != AR_FULL && ref->u.ar.dimen != 0) + { + if (where) + gfc_error ("Actual argument to '%s' at %L must be a coarray " + "and thus shall not have an array designator", + formal->name, &ref->u.ar.where); + return 0; + } + if (ref->type == REF_COMPONENT) + last = ref; + } + + if (last && !last->u.c.component->attr.codimension) + { + if (where) + gfc_error ("Actual argument to '%s' at %L must be a coarray", + formal->name, &actual->where); + return 0; + } + + /* F2008, 12.5.2.6. */ + if (formal->attr.allocatable && + ((last && last->u.c.component->as->corank != formal->as->corank) + || (!last + && actual->symtree->n.sym->as->corank != formal->as->corank))) + { + if (where) + gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)", + formal->name, &actual->where, formal->as->corank, + last ? last->u.c.component->as->corank + : actual->symtree->n.sym->as->corank); + return 0; + } + + /* F2008, 12.5.2.8. */ + if (formal->attr.dimension + && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE) + && !gfc_is_simply_contiguous (actual, true)) + { + if (where) + gfc_error ("Actual argument to '%s' at %L must be simply " + "contiguous", formal->name, &actual->where); + return 0; + } + } + + /* F2008, C1239/C1240. */ + if (actual->expr_type == EXPR_VARIABLE + && (actual->symtree->n.sym->attr.asynchronous + || actual->symtree->n.sym->attr.volatile_) + && (formal->attr.asynchronous || formal->attr.volatile_) + && actual->rank && !gfc_is_simply_contiguous (actual, true) + && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer) + || formal->attr.contiguous)) + { + if (where) + gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape " + "array without CONTIGUOUS attribute - as actual argument at" + " %L is not simply contiguous and both are ASYNCHRONOUS " + "or VOLATILE", formal->name, &actual->where); + return 0; + } + if (symbol_rank (formal) == actual->rank) return 1; @@ -1453,15 +1585,18 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, || formal->as->type == AS_DEFERRED) && actual->expr_type != EXPR_NULL; + /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */ if (rank_check || ranks_must_agree || (formal->attr.pointer && actual->expr_type != EXPR_NULL) || (actual->rank != 0 && !(is_elemental || formal->attr.dimension)) - || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE)) + || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE + && actual->expr_type != EXPR_NULL) + || (actual->rank == 0 && formal->attr.dimension + && gfc_is_coindexed (actual))) { if (where) - gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)", - formal->name, &actual->where, symbol_rank (formal), - actual->rank); + argument_rank_mismatch (formal->name, &actual->where, + symbol_rank (formal), actual->rank); return 0; } else if (actual->rank != 0 && (is_elemental || formal->attr.dimension)) @@ -1474,7 +1609,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, - (F2003) if the actual argument is of type character. */ for (ref = actual->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT) + if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT + && ref->u.ar.dimen > 0) break; /* Not an array element. */ @@ -1499,9 +1635,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, else if (ref == NULL && actual->expr_type != EXPR_NULL) { if (where) - gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)", - formal->name, &actual->where, symbol_rank (formal), - actual->rank); + argument_rank_mismatch (formal->name, &actual->where, + symbol_rank (formal), actual->rank); return 0; } @@ -1582,8 +1717,8 @@ get_sym_storage_size (gfc_symbol *sym) || sym->as->lower[i]->expr_type != EXPR_CONSTANT) return 0; - elements *= mpz_get_ui (sym->as->upper[i]->value.integer) - - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L; + elements *= mpz_get_si (sym->as->upper[i]->value.integer) + - mpz_get_si (sym->as->lower[i]->value.integer) + 1L; } return strlen*elements; @@ -1758,8 +1893,8 @@ get_expr_storage_size (gfc_expr *e) which has a vector subscript. If it has, one is returned, otherwise zero. */ -static int -has_vector_subscript (gfc_expr *e) +int +gfc_has_vector_subscript (gfc_expr *e) { int i; gfc_ref *ref; @@ -1802,7 +1937,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, for (f = formal; f; f = f->next) n++; - new_arg = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *)); + new_arg = XALLOCAVEC (gfc_actual_arglist *, n); for (i = 0; i < n; i++) new_arg[i] = NULL; @@ -1870,6 +2005,20 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, "call at %L", where); return 0; } + + if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer + && (f->sym->attr.allocatable || !f->sym->attr.optional + || (gfc_option.allow_std & GFC_STD_F2008) == 0)) + { + if (where && (f->sym->attr.allocatable || !f->sym->attr.optional)) + gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'", + where, f->sym->name); + else if (where) + gfc_error ("Fortran 2008: Null pointer at %L to non-pointer " + "dummy '%s'", where, f->sym->name); + + return 0; + } if (!compare_parameter (f->sym, a->expr, ranks_must_agree, is_elemental, where)) @@ -1985,6 +2134,68 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, } if (a->expr->expr_type != EXPR_NULL + && (gfc_option.allow_std & GFC_STD_F2008) == 0 + && compare_pointer (f->sym, a->expr) == 2) + { + if (where) + gfc_error ("Fortran 2008: Non-pointer actual argument at %L to " + "pointer dummy '%s'", &a->expr->where,f->sym->name); + return 0; + } + + + /* Fortran 2008, C1242. */ + if (f->sym->attr.pointer && gfc_is_coindexed (a->expr)) + { + if (where) + gfc_error ("Coindexed actual argument at %L to pointer " + "dummy '%s'", + &a->expr->where, f->sym->name); + return 0; + } + + /* Fortran 2008, 12.5.2.5 (no constraint). */ + if (a->expr->expr_type == EXPR_VARIABLE + && f->sym->attr.intent != INTENT_IN + && f->sym->attr.allocatable + && gfc_is_coindexed (a->expr)) + { + if (where) + gfc_error ("Coindexed actual argument at %L to allocatable " + "dummy '%s' requires INTENT(IN)", + &a->expr->where, f->sym->name); + return 0; + } + + /* Fortran 2008, C1237. */ + if (a->expr->expr_type == EXPR_VARIABLE + && (f->sym->attr.asynchronous || f->sym->attr.volatile_) + && gfc_is_coindexed (a->expr) + && (a->expr->symtree->n.sym->attr.volatile_ + || a->expr->symtree->n.sym->attr.asynchronous)) + { + if (where) + gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at " + "at %L requires that dummy %s' has neither " + "ASYNCHRONOUS nor VOLATILE", &a->expr->where, + f->sym->name); + return 0; + } + + /* Fortran 2008, 12.5.2.4 (no constraint). */ + if (a->expr->expr_type == EXPR_VARIABLE + && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value + && gfc_is_coindexed (a->expr) + && gfc_has_ultimate_allocatable (a->expr)) + { + if (where) + gfc_error ("Coindexed actual argument at %L with allocatable " + "ultimate component to dummy '%s' requires either VALUE " + "or INTENT(IN)", &a->expr->where, f->sym->name); + return 0; + } + + if (a->expr->expr_type != EXPR_NULL && compare_allocatable (f->sym, a->expr) == 0) { if (where) @@ -2019,13 +2230,15 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if ((f->sym->attr.intent == INTENT_OUT || f->sym->attr.intent == INTENT_INOUT - || f->sym->attr.volatile_) - && has_vector_subscript (a->expr)) + || f->sym->attr.volatile_ + || f->sym->attr.asynchronous) + && gfc_has_vector_subscript (a->expr)) { if (where) - gfc_error ("Array-section actual argument with vector subscripts " - "at %L is incompatible with INTENT(OUT), INTENT(INOUT) " - "or VOLATILE attribute of the dummy argument '%s'", + gfc_error ("Array-section actual argument with vector " + "subscripts at %L is incompatible with INTENT(OUT), " + "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute " + "of the dummy argument '%s'", &a->expr->where, f->sym->name); return 0; } @@ -2257,7 +2470,7 @@ check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a) } if (n == 0) return t; - p = (argpair *) alloca (n * sizeof (argpair)); + p = XALLOCAVEC (argpair, n); for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next) { @@ -2367,6 +2580,36 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) return FAILURE; } } + + /* Fortran 2008, C1283. */ + if (gfc_pure (NULL) && gfc_is_coindexed (a->expr)) + { + if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT) + { + gfc_error ("Coindexed actual argument at %L in PURE procedure " + "is passed to an INTENT(%s) argument", + &a->expr->where, gfc_intent_string (f_intent)); + return FAILURE; + } + + if (f->sym->attr.pointer) + { + gfc_error ("Coindexed actual argument at %L in PURE procedure " + "is passed to a POINTER dummy argument", + &a->expr->where); + return FAILURE; + } + } + + /* F2008, Section 12.5.2.4. */ + if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS + && gfc_is_coindexed (a->expr)) + { + gfc_error ("Coindexed polymorphic actual argument at %L is passed " + "polymorphic dummy argument '%s'", + &a->expr->where, f->sym->name); + return FAILURE; + } } return SUCCESS; @@ -2573,12 +2816,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; @@ -2590,7 +2835,7 @@ matching_typebound_op (gfc_expr** tb_base, gfc_try result; if (base->expr->ts.type == BT_CLASS) - derived = base->expr->ts.u.derived->components->ts.u.derived; + derived = CLASS_DATA (base->expr)->ts.u.derived; else derived = base->expr->ts.u.derived; @@ -2644,6 +2889,7 @@ matching_typebound_op (gfc_expr** tb_base, if (matches) { *tb_base = base->expr; + *gname = g->specific_st->name; return g->specific; } } @@ -2662,11 +2908,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; @@ -2692,6 +2939,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; @@ -2699,6 +2947,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) { @@ -2764,7 +3013,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) { @@ -2772,10 +3021,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) @@ -2786,7 +3035,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; } @@ -2797,7 +3046,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) @@ -2844,6 +3093,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; @@ -2879,7 +3131,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. */ @@ -2887,7 +3139,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 fbfc47af12c..9c69d7dfc94 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -30,13 +30,13 @@ along with GCC; see the file COPYING3. If not see /* Namespace to hold the resolved symbols for intrinsic subroutines. */ static gfc_namespace *gfc_intrinsic_namespace; -int gfc_init_expr = 0; +bool gfc_init_expr_flag = false; /* Pointers to an intrinsic function and its argument names that are being checked. */ const char *gfc_current_intrinsic; -const char *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; +gfc_intrinsic_arg *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; locus *gfc_current_intrinsic_where; static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym; @@ -50,7 +50,8 @@ static enum sizing; enum klass -{ NO_CLASS = 0, CLASS_ELEMENTAL, CLASS_INQUIRY, CLASS_TRANSFORMATIONAL }; +{ CLASS_IMPURE = 0, CLASS_PURE, CLASS_ELEMENTAL, + CLASS_INQUIRY, CLASS_TRANSFORMATIONAL }; #define ACTUAL_NO 0 #define ACTUAL_YES 1 @@ -112,6 +113,8 @@ gfc_get_intrinsic_sub_symbol (const char *name) sym->attr.flavor = FL_PROCEDURE; sym->attr.proc = PROC_INTRINSIC; + gfc_commit_symbol (sym); + return sym; } @@ -271,6 +274,10 @@ add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type strcat (buf, name); next_sym->lib_name = gfc_get_string (buf); + /* There are no IMPURE ELEMENTAL intrinsics, thus the ELEMENTAL class + also implies PURE. Additionally, there's the PURE class itself. */ + next_sym->pure = (cl == CLASS_ELEMENTAL || cl == CLASS_PURE); + next_sym->elemental = (cl == CLASS_ELEMENTAL); next_sym->inquiry = (cl == CLASS_INQUIRY); next_sym->transformational = (cl == CLASS_TRANSFORMATIONAL); @@ -323,6 +330,7 @@ add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type next_arg->ts.type = type; next_arg->ts.kind = kind; next_arg->optional = optional; + next_arg->value = 0; next_arg->intent = intent; } } @@ -360,7 +368,8 @@ add_sym_0 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty 0 arguments. */ static void -add_sym_0s (const char *name, gfc_isym_id id, int standard, void (*resolve) (gfc_code *)) +add_sym_0s (const char *name, gfc_isym_id id, int standard, + void (*resolve) (gfc_code *)) { gfc_check_f cf; gfc_simplify_f sf; @@ -370,8 +379,8 @@ add_sym_0s (const char *name, gfc_isym_id id, int standard, void (*resolve) (gfc sf.f1 = NULL; rf.s1 = resolve; - add_sym (name, id, NO_CLASS, ACTUAL_NO, BT_UNKNOWN, 0, standard, cf, sf, rf, - (void *) 0); + add_sym (name, id, CLASS_IMPURE, ACTUAL_NO, BT_UNKNOWN, 0, standard, cf, sf, + rf, (void *) 0); } @@ -400,30 +409,6 @@ add_sym_1 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty } -/* Add a symbol to the subroutine list where the subroutine takes - 1 arguments. */ - -static void -add_sym_1s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard, - gfc_try (*check) (gfc_expr *), - gfc_expr *(*simplify) (gfc_expr *), - void (*resolve) (gfc_code *), - const char *a1, bt type1, int kind1, int optional1) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f1 = check; - sf.f1 = simplify; - rf.s1 = resolve; - - add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, INTENT_IN, - (void *) 0); -} - - /* Add a symbol to the function list where the function takes 1 arguments, specifying the intent of the argument. */ @@ -454,13 +439,11 @@ add_sym_1_intent (const char *name, gfc_isym_id id, enum klass cl, 1 arguments, specifying the intent of the argument. */ static void -add_sym_1s_intent (const char *name, gfc_isym_id id, enum klass cl, bt type, - int kind, int standard, - gfc_try (*check) (gfc_expr *), - gfc_expr *(*simplify) (gfc_expr *), - void (*resolve) (gfc_code *), - const char *a1, bt type1, int kind1, int optional1, - sym_intent intent1) +add_sym_1s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, + int standard, gfc_try (*check) (gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *), void (*resolve) (gfc_code *), + const char *a1, bt type1, int kind1, int optional1, + sym_intent intent1) { gfc_check_f cf; gfc_simplify_f sf; @@ -530,16 +513,18 @@ add_sym_2 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty } -/* Add a symbol to the subroutine list where the subroutine takes - 2 arguments. */ +/* Add a symbol to the function list where the function takes + 2 arguments; same as add_sym_2 - but allows to specify the intent. */ static void -add_sym_2s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard, - gfc_try (*check) (gfc_expr *, gfc_expr *), - gfc_expr *(*simplify) (gfc_expr *, gfc_expr *), - void (*resolve) (gfc_code *), - const char *a1, bt type1, int kind1, int optional1, - const char *a2, bt type2, int kind2, int optional2) +add_sym_2_intent (const char *name, gfc_isym_id id, enum klass cl, + int actual_ok, bt type, int kind, int standard, + gfc_try (*check) (gfc_expr *, gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *), + void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *), + const char *a1, bt type1, int kind1, int optional1, + sym_intent intent1, const char *a2, bt type2, int kind2, + int optional2, sym_intent intent2) { gfc_check_f cf; gfc_simplify_f sf; @@ -547,11 +532,11 @@ add_sym_2s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, cf.f2 = check; sf.f2 = simplify; - rf.s1 = resolve; + rf.f2 = resolve; - add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, INTENT_IN, - a2, type2, kind2, optional2, INTENT_IN, + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, intent1, + a2, type2, kind2, optional2, intent2, (void *) 0); } @@ -560,14 +545,14 @@ add_sym_2s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, 2 arguments, specifying the intent of the arguments. */ static void -add_sym_2s_intent (const char *name, gfc_isym_id id, enum klass cl, bt type, - int kind, int standard, - gfc_try (*check) (gfc_expr *, gfc_expr *), - gfc_expr *(*simplify) (gfc_expr *, gfc_expr *), - void (*resolve) (gfc_code *), - const char *a1, bt type1, int kind1, int optional1, - sym_intent intent1, const char *a2, bt type2, int kind2, - int optional2, sym_intent intent2) +add_sym_2s (const char *name, gfc_isym_id id, enum klass cl, bt type, + int kind, int standard, + gfc_try (*check) (gfc_expr *, gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *), + void (*resolve) (gfc_code *), + const char *a1, bt type1, int kind1, int optional1, + sym_intent intent1, const char *a2, bt type2, int kind2, + int optional2, sym_intent intent2) { gfc_check_f cf; gfc_simplify_f sf; @@ -672,46 +657,18 @@ add_sym_3red (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt /* Add a symbol to the subroutine list where the subroutine takes - 3 arguments. */ + 3 arguments, specifying the intent of the arguments. */ static void -add_sym_3s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard, +add_sym_3s (const char *name, gfc_isym_id id, enum klass cl, bt type, + int kind, int standard, gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *), gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), void (*resolve) (gfc_code *), const char *a1, bt type1, int kind1, int optional1, - const char *a2, bt type2, int kind2, int optional2, - const char *a3, bt type3, int kind3, int optional3) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f3 = check; - sf.f3 = simplify; - rf.s1 = resolve; - - add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, INTENT_IN, - a2, type2, kind2, optional2, INTENT_IN, - a3, type3, kind3, optional3, INTENT_IN, - (void *) 0); -} - - -/* Add a symbol to the subroutine list where the subroutine takes - 3 arguments, specifying the intent of the arguments. */ - -static void -add_sym_3s_intent (const char *name, gfc_isym_id id, enum klass cl, bt type, - int kind, int standard, - gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *), - gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), - void (*resolve) (gfc_code *), - const char *a1, bt type1, int kind1, int optional1, - sym_intent intent1, const char *a2, bt type2, int kind2, - int optional2, sym_intent intent2, const char *a3, bt type3, - int kind3, int optional3, sym_intent intent3) + sym_intent intent1, const char *a2, bt type2, int kind2, + int optional2, sym_intent intent2, const char *a3, bt type3, + int kind3, int optional3, sym_intent intent3) { gfc_check_f cf; gfc_simplify_f sf; @@ -956,17 +913,14 @@ gfc_is_intrinsic (gfc_symbol* sym, int subroutine_flag, locus loc) /* See if this intrinsic is allowed in the current standard. */ if (gfc_check_intrinsic_standard (isym, &symstd, false, loc) == FAILURE) { - if (sym->attr.proc == PROC_UNKNOWN) - { - if (gfc_option.warn_intrinsics_std) - gfc_warning_now ("The intrinsic '%s' at %L is not included in the" - " selected standard but %s and '%s' will be" - " treated as if declared EXTERNAL. Use an" - " appropriate -std=* option or define" - " -fall-intrinsics to allow this intrinsic.", - sym->name, &loc, symstd, sym->name); - gfc_add_external (&sym->attr, &loc); - } + if (sym->attr.proc == PROC_UNKNOWN + && gfc_option.warn_intrinsics_std) + gfc_warning_now ("The intrinsic '%s' at %L is not included in the" + " selected standard but %s and '%s' will be" + " treated as if declared EXTERNAL. Use an" + " appropriate -std=* option or define" + " -fall-intrinsics to allow this intrinsic.", + sym->name, &loc, symstd, sym->name); return false; } @@ -1060,6 +1014,30 @@ make_noreturn (void) next_sym[-1].noreturn = 1; } +/* Set the attr.value of the current procedure. */ + +static void +set_attr_value (int n, ...) +{ + gfc_intrinsic_arg *arg; + va_list argp; + int i; + + if (sizing != SZ_NOTHING) + return; + + va_start (argp, n); + arg = next_sym[-1].formal; + + for (i = 0; i < n; i++) + { + gcc_assert (arg != NULL); + arg->value = va_arg (argp, int); + arg = arg->next; + } + va_end (argp); +} + /* Add intrinsic functions. */ @@ -1081,7 +1059,8 @@ add_functions (void) *y = "y", *sz = "size", *sta = "string_a", *stb = "string_b", *z = "z", *ln = "len", *ut = "unit", *han = "handler", *num = "number", *tm = "time", *nm = "name", *md = "mode", - *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command"; + *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command", + *ca = "coarray", *sub = "sub"; int di, dr, dd, dl, dc, dz, ii; @@ -1119,8 +1098,8 @@ add_functions (void) /* The checking function for ACCESS is called gfc_check_access_func because the name gfc_check_access is already used in module.c. */ - add_sym_2 ("access", GFC_ISYM_ACCESS, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - gfc_check_access_func, NULL, gfc_resolve_access, + add_sym_2 ("access", GFC_ISYM_ACCESS, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_access_func, NULL, gfc_resolve_access, nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED); make_generic ("access", GFC_ISYM_ACCESS, GFC_STD_GNU); @@ -1311,6 +1290,12 @@ add_functions (void) gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn, n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED); + add_sym_3 ("bessel_jn", GFC_ISYM_JN2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, + gfc_check_bessel_n2, gfc_simplify_bessel_jn2, gfc_resolve_bessel_n2, + "n1", BT_INTEGER, di, REQUIRED,"n2", BT_INTEGER, di, REQUIRED, + x, BT_REAL, dr, REQUIRED); + set_attr_value (3, true, true, true); + make_generic ("bessel_jn", GFC_ISYM_JN, GFC_STD_F2008); add_sym_1 ("besy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, @@ -1347,16 +1332,50 @@ add_functions (void) gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn, n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED); + add_sym_3 ("bessel_yn", GFC_ISYM_YN2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, + gfc_check_bessel_n2, gfc_simplify_bessel_yn2, gfc_resolve_bessel_n2, + "n1", BT_INTEGER, di, REQUIRED,"n2", BT_INTEGER, di, REQUIRED, + x, BT_REAL, dr, REQUIRED); + set_attr_value (3, true, true, true); + make_generic ("bessel_yn", GFC_ISYM_YN, GFC_STD_F2008); + add_sym_2 ("bge", GFC_ISYM_BGE, CLASS_ELEMENTAL, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_F2008, + gfc_check_bge_bgt_ble_blt, gfc_simplify_bge, NULL, + i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); + + make_generic ("bge", GFC_ISYM_BGE, GFC_STD_F2008); + + add_sym_2 ("bgt", GFC_ISYM_BGT, CLASS_ELEMENTAL, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_F2008, + gfc_check_bge_bgt_ble_blt, gfc_simplify_bgt, NULL, + i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); + + make_generic ("bgt", GFC_ISYM_BGT, GFC_STD_F2008); + add_sym_1 ("bit_size", GFC_ISYM_BIT_SIZE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, gfc_check_i, gfc_simplify_bit_size, NULL, i, BT_INTEGER, di, REQUIRED); make_generic ("bit_size", GFC_ISYM_BIT_SIZE, GFC_STD_F95); + add_sym_2 ("ble", GFC_ISYM_BLE, CLASS_ELEMENTAL, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_F2008, + gfc_check_bge_bgt_ble_blt, gfc_simplify_ble, NULL, + i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); + + make_generic ("ble", GFC_ISYM_BLE, GFC_STD_F2008); + + add_sym_2 ("blt", GFC_ISYM_BLT, CLASS_ELEMENTAL, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_F2008, + gfc_check_bge_bgt_ble_blt, gfc_simplify_blt, NULL, + i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); + + make_generic ("blt", GFC_ISYM_BLT, GFC_STD_F2008); + add_sym_2 ("btest", GFC_ISYM_BTEST, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, - gfc_check_btest, gfc_simplify_btest, gfc_resolve_btest, + gfc_check_bitfcn, gfc_simplify_btest, gfc_resolve_btest, i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED); make_generic ("btest", GFC_ISYM_BTEST, GFC_STD_F95); @@ -1373,14 +1392,14 @@ add_functions (void) make_generic ("char", GFC_ISYM_CHAR, GFC_STD_F77); - add_sym_1 ("chdir", GFC_ISYM_CHDIR, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, + add_sym_1 ("chdir", GFC_ISYM_CHDIR, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, gfc_check_chdir, NULL, gfc_resolve_chdir, nm, BT_CHARACTER, dc, REQUIRED); make_generic ("chdir", GFC_ISYM_CHDIR, GFC_STD_GNU); - add_sym_2 ("chmod", GFC_ISYM_CHMOD, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - gfc_check_chmod, NULL, gfc_resolve_chmod, + add_sym_2 ("chmod", GFC_ISYM_CHMOD, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_chmod, NULL, gfc_resolve_chmod, nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED); make_generic ("chmod", GFC_ISYM_CHMOD, GFC_STD_GNU); @@ -1468,9 +1487,9 @@ add_functions (void) make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95); - add_sym_1 ("ctime", GFC_ISYM_CTIME, NO_CLASS, ACTUAL_NO, BT_CHARACTER, 0, GFC_STD_GNU, - gfc_check_ctime, NULL, gfc_resolve_ctime, - tm, BT_INTEGER, di, REQUIRED); + add_sym_1 ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER, + 0, GFC_STD_GNU, gfc_check_ctime, NULL, gfc_resolve_ctime, + tm, BT_INTEGER, di, REQUIRED); make_generic ("ctime", GFC_ISYM_CTIME, GFC_STD_GNU); @@ -1478,8 +1497,6 @@ add_functions (void) gfc_check_dble, gfc_simplify_dble, gfc_resolve_dble, a, BT_REAL, dr, REQUIRED); - make_alias ("dfloat", GFC_STD_GNU); - make_generic ("dble", GFC_ISYM_DBLE, GFC_STD_F77); add_sym_1 ("digits", GFC_ISYM_DIGITS, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, @@ -1520,10 +1537,28 @@ add_functions (void) make_generic ("dreal", GFC_ISYM_REAL, GFC_STD_GNU); + add_sym_3 ("dshiftl", GFC_ISYM_DSHIFTL, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_dshift, gfc_simplify_dshiftl, gfc_resolve_dshift, + i, BT_INTEGER, di, REQUIRED, + j, BT_INTEGER, di, REQUIRED, + sh, BT_INTEGER, di, REQUIRED); + + make_generic ("dshiftl", GFC_ISYM_DSHIFTL, GFC_STD_F2008); + + add_sym_3 ("dshiftr", GFC_ISYM_DSHIFTR, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_dshift, gfc_simplify_dshiftr, gfc_resolve_dshift, + i, BT_INTEGER, di, REQUIRED, + j, BT_INTEGER, di, REQUIRED, + sh, BT_INTEGER, di, REQUIRED); + + make_generic ("dshiftr", GFC_ISYM_DSHIFTR, GFC_STD_F2008); + add_sym_4 ("eoshift", GFC_ISYM_EOSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, gfc_check_eoshift, NULL, gfc_resolve_eoshift, - ar, BT_REAL, dr, 0, sh, BT_INTEGER, ii, REQUIRED, - bd, BT_REAL, dr, 1, dm, BT_INTEGER, ii, OPTIONAL); + ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, ii, REQUIRED, + bd, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL); make_generic ("eoshift", GFC_ISYM_EOSHIFT, GFC_STD_F95); @@ -1562,14 +1597,14 @@ add_functions (void) make_generic ("erfc_scaled", GFC_ISYM_ERFC_SCALED, GFC_STD_F2008); /* G77 compatibility */ - add_sym_1 ("dtime", GFC_ISYM_DTIME, NO_CLASS, ACTUAL_NO, BT_REAL, 4, GFC_STD_GNU, - gfc_check_dtime_etime, NULL, NULL, + add_sym_1 ("dtime", GFC_ISYM_DTIME, CLASS_IMPURE, ACTUAL_NO, BT_REAL, + 4, GFC_STD_GNU, gfc_check_dtime_etime, NULL, NULL, x, BT_REAL, 4, REQUIRED); make_generic ("dtime", GFC_ISYM_DTIME, GFC_STD_GNU); - add_sym_1 ("etime", GFC_ISYM_ETIME, NO_CLASS, ACTUAL_NO, BT_REAL, 4, GFC_STD_GNU, - gfc_check_dtime_etime, NULL, NULL, + add_sym_1 ("etime", GFC_ISYM_ETIME, CLASS_IMPURE, ACTUAL_NO, BT_REAL, + 4, GFC_STD_GNU, gfc_check_dtime_etime, NULL, NULL, x, BT_REAL, 4, REQUIRED); make_generic ("etime", GFC_ISYM_ETIME, GFC_STD_GNU); @@ -1606,8 +1641,8 @@ add_functions (void) a, BT_UNKNOWN, 0, REQUIRED, mo, BT_UNKNOWN, 0, REQUIRED); - add_sym_0 ("fdate", GFC_ISYM_FDATE, NO_CLASS, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_GNU, - NULL, NULL, gfc_resolve_fdate); + add_sym_0 ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER, + dc, GFC_STD_GNU, NULL, NULL, gfc_resolve_fdate); make_generic ("fdate", GFC_ISYM_FDATE, GFC_STD_GNU); @@ -1618,8 +1653,8 @@ add_functions (void) make_generic ("floor", GFC_ISYM_FLOOR, GFC_STD_F95); /* G77 compatible fnum */ - add_sym_1 ("fnum", GFC_ISYM_FNUM, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - gfc_check_fnum, NULL, gfc_resolve_fnum, + add_sym_1 ("fnum", GFC_ISYM_FNUM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_fnum, NULL, gfc_resolve_fnum, ut, BT_INTEGER, di, REQUIRED); make_generic ("fnum", GFC_ISYM_FNUM, GFC_STD_GNU); @@ -1630,38 +1665,42 @@ add_functions (void) make_generic ("fraction", GFC_ISYM_FRACTION, GFC_STD_F95); - add_sym_2 ("fstat", GFC_ISYM_FSTAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_GNU, gfc_check_fstat, NULL, gfc_resolve_fstat, - ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED); + add_sym_2_intent ("fstat", GFC_ISYM_FSTAT, CLASS_IMPURE, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_GNU, + gfc_check_fstat, NULL, gfc_resolve_fstat, + ut, BT_INTEGER, di, REQUIRED, INTENT_IN, + vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU); - add_sym_1 ("ftell", GFC_ISYM_FTELL, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii, GFC_STD_GNU, - gfc_check_ftell, NULL, gfc_resolve_ftell, + add_sym_1 ("ftell", GFC_ISYM_FTELL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + ii, GFC_STD_GNU, gfc_check_ftell, NULL, gfc_resolve_ftell, ut, BT_INTEGER, di, REQUIRED); make_generic ("ftell", GFC_ISYM_FTELL, GFC_STD_GNU); - add_sym_2 ("fgetc", GFC_ISYM_FGETC, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - gfc_check_fgetputc, NULL, gfc_resolve_fgetc, - ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED); + add_sym_2_intent ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_GNU, + gfc_check_fgetputc, NULL, gfc_resolve_fgetc, + ut, BT_INTEGER, di, REQUIRED, INTENT_IN, + c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); make_generic ("fgetc", GFC_ISYM_FGETC, GFC_STD_GNU); - add_sym_1 ("fget", GFC_ISYM_FGET, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - gfc_check_fgetput, NULL, gfc_resolve_fget, - c, BT_CHARACTER, dc, REQUIRED); + add_sym_1_intent ("fget", GFC_ISYM_FGET, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_fgetput, NULL, gfc_resolve_fget, + c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); make_generic ("fget", GFC_ISYM_FGET, GFC_STD_GNU); - add_sym_2 ("fputc", GFC_ISYM_FPUTC, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - gfc_check_fgetputc, NULL, gfc_resolve_fputc, + add_sym_2 ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_fgetputc, NULL, gfc_resolve_fputc, ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED); make_generic ("fputc", GFC_ISYM_FPUTC, GFC_STD_GNU); - add_sym_1 ("fput", GFC_ISYM_FPUT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - gfc_check_fgetput, NULL, gfc_resolve_fput, + add_sym_1 ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_fgetput, NULL, gfc_resolve_fput, c, BT_CHARACTER, dc, REQUIRED); make_generic ("fput", GFC_ISYM_FPUT, GFC_STD_GNU); @@ -1677,30 +1716,31 @@ add_functions (void) make_generic ("gamma", GFC_ISYM_TGAMMA, GFC_STD_F2008); /* Unix IDs (g77 compatibility) */ - add_sym_1 ("getcwd", GFC_ISYM_GETCWD, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - NULL, NULL, gfc_resolve_getcwd, + add_sym_1 ("getcwd", GFC_ISYM_GETCWD, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getcwd, c, BT_CHARACTER, dc, REQUIRED); make_generic ("getcwd", GFC_ISYM_GETCWD, GFC_STD_GNU); - add_sym_0 ("getgid", GFC_ISYM_GETGID, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - NULL, NULL, gfc_resolve_getgid); + add_sym_0 ("getgid", GFC_ISYM_GETGID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getgid); make_generic ("getgid", GFC_ISYM_GETGID, GFC_STD_GNU); - add_sym_0 ("getpid", GFC_ISYM_GETPID, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - NULL, NULL, gfc_resolve_getpid); + add_sym_0 ("getpid", GFC_ISYM_GETPID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getpid); make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU); - add_sym_0 ("getuid", GFC_ISYM_GETUID, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - NULL, NULL, gfc_resolve_getuid); + add_sym_0 ("getuid", GFC_ISYM_GETUID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getuid); make_generic ("getuid", GFC_ISYM_GETUID, GFC_STD_GNU); - add_sym_1 ("hostnm", GFC_ISYM_HOSTNM, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - gfc_check_hostnm, NULL, gfc_resolve_hostnm, - a, BT_CHARACTER, dc, REQUIRED); + add_sym_1_intent ("hostnm", GFC_ISYM_HOSTNM, CLASS_IMPURE, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_GNU, + gfc_check_hostnm, NULL, gfc_resolve_hostnm, + c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); make_generic ("hostnm", GFC_ISYM_HOSTNM, GFC_STD_GNU); @@ -1730,19 +1770,33 @@ add_functions (void) make_generic ("iand", GFC_ISYM_IAND, GFC_STD_F95); - add_sym_2 ("and", GFC_ISYM_AND, NO_CLASS, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU, - gfc_check_and, gfc_simplify_and, gfc_resolve_and, + add_sym_2 ("and", GFC_ISYM_AND, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL, + dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_and, gfc_resolve_and, i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED); make_generic ("and", GFC_ISYM_AND, GFC_STD_GNU); - add_sym_0 ("iargc", GFC_ISYM_IARGC, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - NULL, NULL, NULL); + add_sym_3red ("iall", GFC_ISYM_IALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, + gfc_check_transf_bit_intrins, gfc_simplify_iall, gfc_resolve_iall, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("iall", GFC_ISYM_IALL, GFC_STD_F2008); + + add_sym_3red ("iany", GFC_ISYM_IANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, + gfc_check_transf_bit_intrins, gfc_simplify_iany, gfc_resolve_iany, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("iany", GFC_ISYM_IANY, GFC_STD_F2008); + + add_sym_0 ("iargc", GFC_ISYM_IARGC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, NULL); make_generic ("iargc", GFC_ISYM_IARGC, GFC_STD_GNU); add_sym_2 ("ibclr", GFC_ISYM_IBCLR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_ibclr, gfc_simplify_ibclr, gfc_resolve_ibclr, + gfc_check_bitfcn, gfc_simplify_ibclr, gfc_resolve_ibclr, i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED); make_generic ("ibclr", GFC_ISYM_IBCLR, GFC_STD_F95); @@ -1755,7 +1809,7 @@ add_functions (void) make_generic ("ibits", GFC_ISYM_IBITS, GFC_STD_F95); add_sym_2 ("ibset", GFC_ISYM_IBSET, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_ibset, gfc_simplify_ibset, gfc_resolve_ibset, + gfc_check_bitfcn, gfc_simplify_ibset, gfc_resolve_ibset, i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED); make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95); @@ -1773,17 +1827,21 @@ add_functions (void) make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95); - add_sym_2 ("xor", GFC_ISYM_XOR, NO_CLASS, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU, - gfc_check_and, gfc_simplify_xor, gfc_resolve_xor, + add_sym_2 ("xor", GFC_ISYM_XOR, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL, + dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_xor, gfc_resolve_xor, i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED); make_generic ("xor", GFC_ISYM_XOR, GFC_STD_GNU); - add_sym_0 ("ierrno", GFC_ISYM_IERRNO, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - NULL, NULL, gfc_resolve_ierrno); + add_sym_0 ("ierrno", GFC_ISYM_IERRNO, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, gfc_resolve_ierrno); make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU); + add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, + gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index, + ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED); + /* The resolution function for INDEX is called gfc_resolve_index_func because the name gfc_resolve_index is already used in resolve.c. */ add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES, @@ -1834,21 +1892,28 @@ add_functions (void) make_generic ("ior", GFC_ISYM_IOR, GFC_STD_F95); - add_sym_2 ("or", GFC_ISYM_OR, NO_CLASS, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU, - gfc_check_and, gfc_simplify_or, gfc_resolve_or, + add_sym_2 ("or", GFC_ISYM_OR, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL, + dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_or, gfc_resolve_or, i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED); make_generic ("or", GFC_ISYM_OR, GFC_STD_GNU); + add_sym_3red ("iparity", GFC_ISYM_IPARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, + gfc_check_transf_bit_intrins, gfc_simplify_iparity, gfc_resolve_iparity, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("iparity", GFC_ISYM_IPARITY, GFC_STD_F2008); + /* The following function is for G77 compatibility. */ - add_sym_1 ("irand", GFC_ISYM_IRAND, NO_CLASS, ACTUAL_NO, BT_INTEGER, 4, GFC_STD_GNU, - gfc_check_irand, NULL, NULL, + add_sym_1 ("irand", GFC_ISYM_IRAND, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + 4, GFC_STD_GNU, gfc_check_irand, NULL, NULL, i, BT_INTEGER, 4, OPTIONAL); make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU); - add_sym_1 ("isatty", GFC_ISYM_ISATTY, NO_CLASS, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU, - gfc_check_isatty, NULL, gfc_resolve_isatty, + add_sym_1 ("isatty", GFC_ISYM_ISATTY, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL, + dl, GFC_STD_GNU, gfc_check_isatty, NULL, gfc_resolve_isatty, ut, BT_INTEGER, di, REQUIRED); make_generic ("isatty", GFC_ISYM_ISATTY, GFC_STD_GNU); @@ -1874,14 +1939,16 @@ add_functions (void) make_generic ("isnan", GFC_ISYM_ISNAN, GFC_STD_GNU); - add_sym_2 ("rshift", GFC_ISYM_RSHIFT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - gfc_check_ishft, NULL, gfc_resolve_rshift, + add_sym_2 ("rshift", GFC_ISYM_RSHIFT, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_GNU, + gfc_check_ishft, gfc_simplify_rshift, gfc_resolve_rshift, i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED); make_generic ("rshift", GFC_ISYM_RSHIFT, GFC_STD_GNU); - add_sym_2 ("lshift", GFC_ISYM_LSHIFT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - gfc_check_ishft, NULL, gfc_resolve_lshift, + add_sym_2 ("lshift", GFC_ISYM_LSHIFT, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_GNU, + gfc_check_ishft, gfc_simplify_lshift, gfc_resolve_lshift, i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED); make_generic ("lshift", GFC_ISYM_LSHIFT, GFC_STD_GNU); @@ -1899,8 +1966,8 @@ add_functions (void) make_generic ("ishftc", GFC_ISYM_ISHFTC, GFC_STD_F95); - add_sym_2 ("kill", GFC_ISYM_KILL, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - gfc_check_kill, NULL, gfc_resolve_kill, + add_sym_2 ("kill", GFC_ISYM_KILL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_kill, NULL, gfc_resolve_kill, a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED); make_generic ("kill", GFC_ISYM_KILL, GFC_STD_GNU); @@ -1919,6 +1986,14 @@ add_functions (void) make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95); + add_sym_3 ("lcobound", GFC_ISYM_LCOBOUND, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_lcobound, gfc_simplify_lcobound, gfc_resolve_lcobound, + ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("lcobound", GFC_ISYM_LCOBOUND, GFC_STD_F2008); + add_sym_1 ("leadz", GFC_ISYM_LEADZ, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_i, gfc_simplify_leadz, NULL, @@ -1984,7 +2059,7 @@ add_functions (void) make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77); - add_sym_2 ("link", GFC_ISYM_LINK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, + add_sym_2 ("link", GFC_ISYM_LINK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, gfc_check_link, NULL, gfc_resolve_link, p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED); @@ -2034,18 +2109,36 @@ add_functions (void) make_generic ("logical", GFC_ISYM_LOGICAL, GFC_STD_F95); - add_sym_2 ("lstat", GFC_ISYM_LSTAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_GNU, gfc_check_stat, NULL, gfc_resolve_lstat, - nm, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED); + add_sym_2_intent ("lstat", GFC_ISYM_LSTAT, CLASS_IMPURE, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_GNU, + gfc_check_stat, NULL, gfc_resolve_lstat, + nm, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); make_generic ("lstat", GFC_ISYM_LSTAT, GFC_STD_GNU); - add_sym_1 ("malloc", GFC_ISYM_MALLOC, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii, + add_sym_1 ("malloc", GFC_ISYM_MALLOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii, GFC_STD_GNU, gfc_check_malloc, NULL, gfc_resolve_malloc, sz, BT_INTEGER, di, REQUIRED); make_generic ("malloc", GFC_ISYM_MALLOC, GFC_STD_GNU); + add_sym_2 ("maskl", GFC_ISYM_MASKL, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_mask, gfc_simplify_maskl, gfc_resolve_mask, + i, BT_INTEGER, di, REQUIRED, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("maskl", GFC_ISYM_MASKL, GFC_STD_F2008); + + add_sym_2 ("maskr", GFC_ISYM_MASKR, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_mask, gfc_simplify_maskr, gfc_resolve_mask, + i, BT_INTEGER, di, REQUIRED, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("maskr", GFC_ISYM_MASKR, GFC_STD_F2008); + add_sym_2 ("matmul", GFC_ISYM_MATMUL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, gfc_check_matmul, gfc_simplify_matmul, gfc_resolve_matmul, ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED); @@ -2101,13 +2194,13 @@ add_functions (void) make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95); - add_sym_0 ("mclock", GFC_ISYM_MCLOCK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, + add_sym_0 ("mclock", GFC_ISYM_MCLOCK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock); make_generic ("mclock", GFC_ISYM_MCLOCK, GFC_STD_GNU); - add_sym_0 ("mclock8", GFC_ISYM_MCLOCK8, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock8); + add_sym_0 ("mclock8", GFC_ISYM_MCLOCK8, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock8); make_generic ("mclock8", GFC_ISYM_MCLOCK8, GFC_STD_GNU); @@ -2118,6 +2211,16 @@ add_functions (void) make_generic ("merge", GFC_ISYM_MERGE, GFC_STD_F95); + add_sym_3 ("merge_bits", GFC_ISYM_MERGE_BITS, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_merge_bits, gfc_simplify_merge_bits, + gfc_resolve_merge_bits, + i, BT_INTEGER, di, REQUIRED, + j, BT_INTEGER, di, REQUIRED, + msk, BT_INTEGER, di, REQUIRED); + + make_generic ("merge_bits", GFC_ISYM_MERGE_BITS, GFC_STD_F2008); + /* Note: amin0 is equivalent to real(min), min1 is equivalent to int(min). */ @@ -2215,6 +2318,13 @@ add_functions (void) make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95); + add_sym_2 ("norm2", GFC_ISYM_NORM2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2008, gfc_check_norm2, gfc_simplify_norm2, gfc_resolve_norm2, + x, BT_REAL, dr, REQUIRED, + dm, BT_INTEGER, ii, OPTIONAL); + + make_generic ("norm2", GFC_ISYM_NORM2, GFC_STD_F2008); + add_sym_1 ("null", GFC_ISYM_NULL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, gfc_check_null, gfc_simplify_null, NULL, mo, BT_INTEGER, di, OPTIONAL); @@ -2231,6 +2341,28 @@ add_functions (void) make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95); + + add_sym_2 ("parity", GFC_ISYM_PARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, + GFC_STD_F2008, gfc_check_parity, gfc_simplify_parity, gfc_resolve_parity, + msk, BT_LOGICAL, dl, REQUIRED, + dm, BT_INTEGER, ii, OPTIONAL); + + make_generic ("parity", GFC_ISYM_PARITY, GFC_STD_F2008); + + add_sym_1 ("popcnt", GFC_ISYM_POPCNT, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_i, gfc_simplify_popcnt, NULL, + i, BT_INTEGER, di, REQUIRED); + + make_generic ("popcnt", GFC_ISYM_POPCNT, GFC_STD_F2008); + + add_sym_1 ("poppar", GFC_ISYM_POPPAR, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_i, gfc_simplify_poppar, NULL, + i, BT_INTEGER, di, REQUIRED); + + make_generic ("poppar", GFC_ISYM_POPPAR, GFC_STD_F2008); + add_sym_1 ("precision", GFC_ISYM_PRECISION, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, gfc_check_precision, gfc_simplify_precision, NULL, x, BT_UNKNOWN, 0, REQUIRED); @@ -2257,8 +2389,8 @@ add_functions (void) make_generic ("radix", GFC_ISYM_RADIX, GFC_STD_F95); /* The following function is for G77 compatibility. */ - add_sym_1 ("rand", GFC_ISYM_RAND, NO_CLASS, ACTUAL_NO, BT_REAL, 4, GFC_STD_GNU, - gfc_check_rand, NULL, NULL, + add_sym_1 ("rand", GFC_ISYM_RAND, CLASS_IMPURE, ACTUAL_NO, BT_REAL, + 4, GFC_STD_GNU, gfc_check_rand, NULL, NULL, i, BT_INTEGER, 4, OPTIONAL); /* Compatibility with HP FORTRAN 77/iX Reference. Note, rand() and ran() @@ -2283,16 +2415,20 @@ add_functions (void) a, BT_UNKNOWN, dr, REQUIRED); add_sym_1 ("float", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, - gfc_check_i, gfc_simplify_float, NULL, + gfc_check_float, gfc_simplify_float, NULL, a, BT_INTEGER, di, REQUIRED); + add_sym_1 ("dfloat", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, + gfc_check_float, gfc_simplify_dble, gfc_resolve_dble, + a, BT_REAL, dr, REQUIRED); + add_sym_1 ("sngl", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, - NULL, gfc_simplify_sngl, NULL, + gfc_check_sngl, gfc_simplify_sngl, NULL, a, BT_REAL, dd, REQUIRED); make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77); - add_sym_2 ("rename", GFC_ISYM_RENAME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, + add_sym_2 ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, gfc_check_rename, NULL, gfc_resolve_rename, p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED); @@ -2338,14 +2474,14 @@ add_functions (void) make_generic ("scan", GFC_ISYM_SCAN, GFC_STD_F95); /* Added for G77 compatibility garbage. */ - add_sym_0 ("second", GFC_ISYM_SECOND, NO_CLASS, ACTUAL_NO, BT_REAL, 4, GFC_STD_GNU, - NULL, NULL, NULL); + add_sym_0 ("second", GFC_ISYM_SECOND, CLASS_IMPURE, ACTUAL_NO, BT_REAL, + 4, GFC_STD_GNU, NULL, NULL, NULL); make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU); /* Added for G77 compatibility. */ - add_sym_1 ("secnds", GFC_ISYM_SECNDS, NO_CLASS, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_secnds, NULL, gfc_resolve_secnds, + add_sym_1 ("secnds", GFC_ISYM_SECNDS, CLASS_IMPURE, ACTUAL_NO, BT_REAL, + dr, GFC_STD_GNU, gfc_check_secnds, NULL, gfc_resolve_secnds, x, BT_REAL, dr, REQUIRED); make_generic ("secnds", GFC_ISYM_SECNDS, GFC_STD_GNU); @@ -2363,10 +2499,11 @@ add_functions (void) make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95); - add_sym_2 ("selected_real_kind", GFC_ISYM_SR_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, + add_sym_3 ("selected_real_kind", GFC_ISYM_SR_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, gfc_check_selected_real_kind, gfc_simplify_selected_real_kind, NULL, - p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL); + p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL, + "radix", BT_INTEGER, di, OPTIONAL); make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95); @@ -2383,6 +2520,30 @@ add_functions (void) make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95); + add_sym_2 ("shifta", GFC_ISYM_SHIFTA, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_shift, gfc_simplify_shifta, gfc_resolve_shift, + i, BT_INTEGER, di, REQUIRED, + sh, BT_INTEGER, di, REQUIRED); + + make_generic ("shifta", GFC_ISYM_SHIFTA, GFC_STD_F2008); + + add_sym_2 ("shiftl", GFC_ISYM_SHIFTL, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_shift, gfc_simplify_shiftl, gfc_resolve_shift, + i, BT_INTEGER, di, REQUIRED, + sh, BT_INTEGER, di, REQUIRED); + + make_generic ("shiftl", GFC_ISYM_SHIFTL, GFC_STD_F2008); + + add_sym_2 ("shiftr", GFC_ISYM_SHIFTR, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_shift, gfc_simplify_shiftr, gfc_resolve_shift, + i, BT_INTEGER, di, REQUIRED, + sh, BT_INTEGER, di, REQUIRED); + + make_generic ("shiftr", GFC_ISYM_SHIFTR, GFC_STD_F2008); + add_sym_2 ("sign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign, a, BT_REAL, dr, REQUIRED, b, BT_REAL, dr, REQUIRED); @@ -2397,8 +2558,8 @@ add_functions (void) make_generic ("sign", GFC_ISYM_SIGN, GFC_STD_F77); - add_sym_2 ("signal", GFC_ISYM_SIGNAL, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - gfc_check_signal, NULL, gfc_resolve_signal, + add_sym_2 ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_signal, NULL, gfc_resolve_signal, num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED); make_generic ("signal", GFC_ISYM_SIGNAL, GFC_STD_GNU); @@ -2441,12 +2602,15 @@ add_functions (void) make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95); - add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii, + add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii, GFC_STD_GNU, gfc_check_sizeof, NULL, NULL, 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, @@ -2481,12 +2645,20 @@ add_functions (void) make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77); - add_sym_2 ("stat", GFC_ISYM_STAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_GNU, gfc_check_stat, NULL, gfc_resolve_stat, - nm, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED); + add_sym_2_intent ("stat", GFC_ISYM_STAT, CLASS_IMPURE, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_GNU, + gfc_check_stat, NULL, gfc_resolve_stat, + nm, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); 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, @@ -2494,13 +2666,13 @@ add_functions (void) make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95); - add_sym_2 ("symlnk", GFC_ISYM_SYMLNK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, + add_sym_2 ("symlnk", GFC_ISYM_SYMLNK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, gfc_check_symlnk, NULL, gfc_resolve_symlnk, p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED); make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU); - add_sym_1 ("system", GFC_ISYM_SYSTEM, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, + add_sym_1 ("system", GFC_ISYM_SYSTEM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, NULL, NULL, NULL, com, BT_CHARACTER, dc, REQUIRED); @@ -2526,13 +2698,17 @@ add_functions (void) make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77); - add_sym_0 ("time", GFC_ISYM_TIME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - NULL, NULL, gfc_resolve_time); + add_sym_2 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, + gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image, + ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL); + + add_sym_0 ("time", GFC_ISYM_TIME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time); make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU); - add_sym_0 ("time8", GFC_ISYM_TIME8, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - NULL, NULL, gfc_resolve_time8); + add_sym_0 ("time8", GFC_ISYM_TIME8, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time8); make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU); @@ -2568,8 +2744,8 @@ add_functions (void) make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95); - add_sym_1 ("ttynam", GFC_ISYM_TTYNAM, NO_CLASS, ACTUAL_NO, BT_CHARACTER, 0, GFC_STD_GNU, - gfc_check_ttynam, NULL, gfc_resolve_ttynam, + add_sym_1 ("ttynam", GFC_ISYM_TTYNAM, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER, + 0, GFC_STD_GNU, gfc_check_ttynam, NULL, gfc_resolve_ttynam, ut, BT_INTEGER, di, REQUIRED); make_generic ("ttynam", GFC_ISYM_TTYNAM, GFC_STD_GNU); @@ -2582,16 +2758,24 @@ add_functions (void) make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95); + add_sym_3 ("ucobound", GFC_ISYM_UCOBOUND, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_ucobound, gfc_simplify_ucobound, gfc_resolve_ucobound, + ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("ucobound", GFC_ISYM_UCOBOUND, GFC_STD_F2008); + /* g77 compatibility for UMASK. */ - add_sym_1 ("umask", GFC_ISYM_UMASK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, + add_sym_1 ("umask", GFC_ISYM_UMASK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, gfc_check_umask, NULL, gfc_resolve_umask, msk, BT_INTEGER, di, REQUIRED); make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU); /* g77 compatibility for UNLINK. */ - add_sym_1 ("unlink", GFC_ISYM_UNLINK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - gfc_check_unlink, NULL, gfc_resolve_unlink, + add_sym_1 ("unlink", GFC_ISYM_UNLINK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_unlink, NULL, gfc_resolve_unlink, "path", BT_CHARACTER, dc, REQUIRED); make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU); @@ -2611,7 +2795,7 @@ add_functions (void) make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95); - add_sym_1 ("loc", GFC_ISYM_LOC, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii, + add_sym_1 ("loc", GFC_ISYM_LOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii, GFC_STD_GNU, gfc_check_loc, NULL, gfc_resolve_loc, x, BT_UNKNOWN, 0, REQUIRED); @@ -2649,96 +2833,114 @@ add_subroutines (void) make_noreturn(); - add_sym_1s_intent ("cpu_time", GFC_ISYM_CPU_TIME, NO_CLASS, BT_UNKNOWN, 0, - GFC_STD_F95, gfc_check_cpu_time, NULL, - gfc_resolve_cpu_time, - tm, BT_REAL, dr, REQUIRED, INTENT_OUT); + add_sym_1s ("cpu_time", GFC_ISYM_CPU_TIME, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_F95, gfc_check_cpu_time, NULL, gfc_resolve_cpu_time, + tm, BT_REAL, dr, REQUIRED, INTENT_OUT); /* More G77 compatibility garbage. */ - add_sym_2s ("ctime", GFC_ISYM_CTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_2s ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub, - tm, BT_INTEGER, di, REQUIRED, res, BT_CHARACTER, dc, REQUIRED); + tm, BT_INTEGER, di, REQUIRED, INTENT_IN, + res, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); - add_sym_1s ("idate", GFC_ISYM_IDATE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_1s ("idate", GFC_ISYM_IDATE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_itime_idate, NULL, gfc_resolve_idate, - vl, BT_INTEGER, 4, REQUIRED); + vl, BT_INTEGER, 4, REQUIRED, INTENT_OUT); - add_sym_1s ("itime", GFC_ISYM_ITIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_1s ("itime", GFC_ISYM_ITIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_itime_idate, NULL, gfc_resolve_itime, - vl, BT_INTEGER, 4, REQUIRED); + vl, BT_INTEGER, 4, REQUIRED, INTENT_OUT); - add_sym_2s ("ltime", GFC_ISYM_LTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_2s ("ltime", GFC_ISYM_LTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_ltime_gmtime, NULL, gfc_resolve_ltime, - tm, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED); + tm, BT_INTEGER, di, REQUIRED, INTENT_IN, + vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); - add_sym_2s ("gmtime", GFC_ISYM_GMTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_ltime_gmtime, NULL, gfc_resolve_gmtime, - tm, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED); + add_sym_2s ("gmtime", GFC_ISYM_GMTIME, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_ltime_gmtime, NULL, gfc_resolve_gmtime, + tm, BT_INTEGER, di, REQUIRED, INTENT_IN, + vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); - add_sym_1s ("second", GFC_ISYM_SECOND, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_second_sub, NULL, gfc_resolve_second_sub, - tm, BT_REAL, dr, REQUIRED); + add_sym_1s ("second", GFC_ISYM_SECOND, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_second_sub, NULL, gfc_resolve_second_sub, + tm, BT_REAL, dr, REQUIRED, INTENT_OUT); - add_sym_2s ("chdir", GFC_ISYM_CHDIR, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_2s ("chdir", GFC_ISYM_CHDIR, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub, - name, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_3s ("chmod", GFC_ISYM_CHMOD, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_3s ("chmod", GFC_ISYM_CHMOD, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_chmod_sub, NULL, gfc_resolve_chmod_sub, - name, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED, - st, BT_INTEGER, di, OPTIONAL); + name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + md, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_4s ("date_and_time", GFC_ISYM_DATE_AND_TIME, NO_CLASS, BT_UNKNOWN, 0, - GFC_STD_F95, gfc_check_date_and_time, NULL, NULL, + add_sym_4s ("date_and_time", GFC_ISYM_DATE_AND_TIME, CLASS_IMPURE, BT_UNKNOWN, + 0, GFC_STD_F95, gfc_check_date_and_time, NULL, NULL, dt, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, tm, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, zn, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, vl, BT_INTEGER, di, OPTIONAL, INTENT_OUT); /* More G77 compatibility garbage. */ - add_sym_2s ("etime", GFC_ISYM_ETIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_2s ("etime", GFC_ISYM_ETIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_dtime_etime_sub, NULL, gfc_resolve_etime_sub, - vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED); + vl, BT_REAL, 4, REQUIRED, INTENT_OUT, + tm, BT_REAL, 4, REQUIRED, INTENT_OUT); - add_sym_2s ("dtime", GFC_ISYM_DTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_2s ("dtime", GFC_ISYM_DTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_dtime_etime_sub, NULL, gfc_resolve_dtime_sub, - vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED); - - add_sym_1s ("fdate", GFC_ISYM_FDATE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + vl, BT_REAL, 4, REQUIRED, INTENT_OUT, + tm, BT_REAL, 4, REQUIRED, INTENT_OUT); + + add_sym_5s ("execute_command_line", GFC_ISYM_EXECUTE_COMMAND_LINE, + CLASS_IMPURE , BT_UNKNOWN, 0, GFC_STD_F2008, + NULL, NULL, gfc_resolve_execute_command_line, + "command", BT_CHARACTER, dc, REQUIRED, INTENT_IN, + "wait", BT_LOGICAL, dl, OPTIONAL, INTENT_IN, + "exitstat", BT_INTEGER, di, OPTIONAL, INTENT_INOUT, + "cmdstat", BT_INTEGER, di, OPTIONAL, INTENT_OUT, + "cmdmsg", BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); + + add_sym_1s ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub, - dt, BT_CHARACTER, dc, REQUIRED); + dt, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); - add_sym_1s ("gerror", GFC_ISYM_GERROR, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_gerror, NULL, gfc_resolve_gerror, res, BT_CHARACTER, - dc, REQUIRED); + add_sym_1s ("gerror", GFC_ISYM_GERROR, CLASS_IMPURE, BT_UNKNOWN, + 0, GFC_STD_GNU, gfc_check_gerror, NULL, gfc_resolve_gerror, + res, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); - add_sym_2s ("getcwd", GFC_ISYM_GETCWD, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub, - c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + add_sym_2s ("getcwd", GFC_ISYM_GETCWD, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub, + c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_2s ("getenv", GFC_ISYM_GETENV, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - NULL, NULL, NULL, - name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, - REQUIRED); + add_sym_2s ("getenv", GFC_ISYM_GETENV, CLASS_IMPURE, BT_UNKNOWN, + 0, GFC_STD_GNU, NULL, NULL, NULL, + name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + val, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); - add_sym_2s ("getarg", GFC_ISYM_GETARG, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_getarg, NULL, gfc_resolve_getarg, - pos, BT_INTEGER, di, REQUIRED, val, BT_CHARACTER, dc, REQUIRED); + add_sym_2s ("getarg", GFC_ISYM_GETARG, CLASS_IMPURE, BT_UNKNOWN, + 0, GFC_STD_GNU, gfc_check_getarg, NULL, gfc_resolve_getarg, + pos, BT_INTEGER, di, REQUIRED, INTENT_IN, + val, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); - add_sym_1s ("getlog", GFC_ISYM_GETLOG, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER, - dc, REQUIRED); + add_sym_1s ("getlog", GFC_ISYM_GETLOG, CLASS_IMPURE, BT_UNKNOWN, + 0, GFC_STD_GNU, gfc_check_getlog, NULL, gfc_resolve_getlog, + c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); /* F2003 commandline routines. */ - add_sym_3s_intent ("get_command", GFC_ISYM_GET_COMMAND, NO_CLASS, BT_UNKNOWN, - 0, GFC_STD_F2003, NULL, NULL, gfc_resolve_get_command, - com, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, - length, BT_INTEGER, di, OPTIONAL, INTENT_OUT, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + add_sym_3s ("get_command", GFC_ISYM_GET_COMMAND, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F2003, + NULL, NULL, gfc_resolve_get_command, + com, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, + length, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_4s ("get_command_argument", GFC_ISYM_GET_COMMAND_ARGUMENT, NO_CLASS, - BT_UNKNOWN, 0, GFC_STD_F2003, NULL, NULL, + add_sym_4s ("get_command_argument", GFC_ISYM_GET_COMMAND_ARGUMENT, + CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003, NULL, NULL, gfc_resolve_get_command_argument, num, BT_INTEGER, di, REQUIRED, INTENT_IN, val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, @@ -2748,7 +2950,7 @@ add_subroutines (void) /* F2003 subroutine to get environment variables. */ add_sym_5s ("get_environment_variable", GFC_ISYM_GET_ENVIRONMENT_VARIABLE, - NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003, + CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003, NULL, NULL, gfc_resolve_get_environment_variable, name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, @@ -2756,10 +2958,11 @@ add_subroutines (void) st, BT_INTEGER, di, OPTIONAL, INTENT_OUT, trim_name, BT_LOGICAL, dl, OPTIONAL, INTENT_IN); - add_sym_2s_intent ("move_alloc", GFC_ISYM_MOVE_ALLOC, NO_CLASS, BT_UNKNOWN, 0, - GFC_STD_F2003, gfc_check_move_alloc, NULL, NULL, - f, BT_UNKNOWN, 0, REQUIRED, INTENT_INOUT, - t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT); + add_sym_2s ("move_alloc", GFC_ISYM_MOVE_ALLOC, CLASS_PURE, BT_UNKNOWN, 0, + GFC_STD_F2003, + gfc_check_move_alloc, NULL, NULL, + f, BT_UNKNOWN, 0, REQUIRED, INTENT_INOUT, + t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT); add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0, GFC_STD_F95, gfc_check_mvbits, gfc_simplify_mvbits, @@ -2770,144 +2973,164 @@ add_subroutines (void) t, BT_INTEGER, di, REQUIRED, INTENT_INOUT, tp, BT_INTEGER, di, REQUIRED, INTENT_IN); - add_sym_1s_intent ("random_number", GFC_ISYM_RANDOM_NUMBER, NO_CLASS, - BT_UNKNOWN, 0, GFC_STD_F95, gfc_check_random_number, NULL, - gfc_resolve_random_number, - h, BT_REAL, dr, REQUIRED, INTENT_OUT); + add_sym_1s ("random_number", GFC_ISYM_RANDOM_NUMBER, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F95, + gfc_check_random_number, NULL, gfc_resolve_random_number, + h, BT_REAL, dr, REQUIRED, INTENT_OUT); - add_sym_3s_intent ("random_seed", GFC_ISYM_RANDOM_SEED, NO_CLASS, - BT_UNKNOWN, 0, GFC_STD_F95, - gfc_check_random_seed, NULL, gfc_resolve_random_seed, - sz, BT_INTEGER, di, OPTIONAL, INTENT_OUT, - pt, BT_INTEGER, di, OPTIONAL, INTENT_IN, - gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + add_sym_3s ("random_seed", GFC_ISYM_RANDOM_SEED, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F95, + gfc_check_random_seed, NULL, gfc_resolve_random_seed, + sz, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + pt, BT_INTEGER, di, OPTIONAL, INTENT_IN, + gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT); /* More G77 compatibility garbage. */ - add_sym_3s ("alarm", GFC_ISYM_ALARM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_3s ("alarm", GFC_ISYM_ALARM, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub, - sec, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED, - st, BT_INTEGER, di, OPTIONAL); + sec, BT_INTEGER, di, REQUIRED, INTENT_IN, + han, BT_UNKNOWN, 0, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_1s ("srand", GFC_ISYM_SRAND, NO_CLASS, BT_UNKNOWN, di, GFC_STD_GNU, - gfc_check_srand, NULL, gfc_resolve_srand, - "seed", BT_INTEGER, 4, REQUIRED); + add_sym_1s ("srand", GFC_ISYM_SRAND, CLASS_IMPURE, BT_UNKNOWN, + di, GFC_STD_GNU, gfc_check_srand, NULL, gfc_resolve_srand, + "seed", BT_INTEGER, 4, REQUIRED, INTENT_IN); - add_sym_1s ("exit", GFC_ISYM_EXIT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_1s ("exit", GFC_ISYM_EXIT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_exit, NULL, gfc_resolve_exit, - st, BT_INTEGER, di, OPTIONAL); + st, BT_INTEGER, di, OPTIONAL, INTENT_IN); make_noreturn(); - add_sym_3s ("fgetc", GFC_ISYM_FGETC, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_3s ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_fgetputc_sub, NULL, gfc_resolve_fgetc_sub, - ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED, - st, BT_INTEGER, di, OPTIONAL); + ut, BT_INTEGER, di, REQUIRED, INTENT_IN, + c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_2s ("fget", GFC_ISYM_FGET, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_2s ("fget", GFC_ISYM_FGET, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_fgetput_sub, NULL, gfc_resolve_fget_sub, - c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_1s ("flush", GFC_ISYM_FLUSH, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_1s ("flush", GFC_ISYM_FLUSH, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_flush, NULL, gfc_resolve_flush, - ut, BT_INTEGER, di, OPTIONAL); + ut, BT_INTEGER, di, OPTIONAL, INTENT_IN); - add_sym_3s ("fputc", GFC_ISYM_FPUTC, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_3s ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub, - ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED, - st, BT_INTEGER, di, OPTIONAL); + ut, BT_INTEGER, di, REQUIRED, INTENT_IN, + c, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_2s ("fput", GFC_ISYM_FPUT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_2s ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub, - c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + c, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_1s ("free", GFC_ISYM_FREE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_1s ("free", GFC_ISYM_FREE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_free, NULL, gfc_resolve_free, - ptr, BT_INTEGER, ii, REQUIRED); + ptr, BT_INTEGER, ii, REQUIRED, INTENT_INOUT); - add_sym_4s ("fseek", GFC_ISYM_FSEEK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_fseek_sub, NULL, gfc_resolve_fseek_sub, - ut, BT_INTEGER, di, REQUIRED, INTENT_IN, + add_sym_4s ("fseek", GFC_ISYM_FSEEK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_fseek_sub, NULL, gfc_resolve_fseek_sub, + ut, BT_INTEGER, di, REQUIRED, INTENT_IN, of, BT_INTEGER, di, REQUIRED, INTENT_IN, - whence, BT_INTEGER, di, REQUIRED, INTENT_IN, + whence, BT_INTEGER, di, REQUIRED, INTENT_IN, st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_2s ("ftell", GFC_ISYM_FTELL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_2s ("ftell", GFC_ISYM_FTELL, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub, - ut, BT_INTEGER, di, REQUIRED, of, BT_INTEGER, ii, REQUIRED); + ut, BT_INTEGER, di, REQUIRED, INTENT_IN, + of, BT_INTEGER, ii, REQUIRED, INTENT_OUT); - add_sym_2s ("hostnm", GFC_ISYM_HOSTNM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub, - c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + add_sym_2s ("hostnm", GFC_ISYM_HOSTNM, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub, + c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_3s ("kill", GFC_ISYM_KILL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_kill_sub, - NULL, gfc_resolve_kill_sub, c, BT_INTEGER, di, REQUIRED, - val, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + add_sym_3s ("kill", GFC_ISYM_KILL, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_kill_sub, NULL, gfc_resolve_kill_sub, + c, BT_INTEGER, di, REQUIRED, INTENT_IN, + val, BT_INTEGER, di, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_3s ("link", GFC_ISYM_LINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_3s ("link", GFC_ISYM_LINK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_link_sub, NULL, gfc_resolve_link_sub, - p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, - dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_1s ("perror", GFC_ISYM_PERROR, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_perror, NULL, gfc_resolve_perror, - "string", BT_CHARACTER, dc, REQUIRED); + add_sym_1s ("perror", GFC_ISYM_PERROR, CLASS_IMPURE, BT_UNKNOWN, + 0, GFC_STD_GNU, gfc_check_perror, NULL, gfc_resolve_perror, + "string", BT_CHARACTER, dc, REQUIRED, INTENT_IN); - add_sym_3s ("rename", GFC_ISYM_RENAME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_rename_sub, NULL, gfc_resolve_rename_sub, - p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, - dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + add_sym_3s ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_rename_sub, NULL, gfc_resolve_rename_sub, + p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_1s ("sleep", GFC_ISYM_SLEEP, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_1s ("sleep", GFC_ISYM_SLEEP, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub, - sec, BT_INTEGER, di, REQUIRED); + sec, BT_INTEGER, di, REQUIRED, INTENT_IN); - add_sym_3s ("fstat", GFC_ISYM_FSTAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_3s ("fstat", GFC_ISYM_FSTAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub, - ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED, - st, BT_INTEGER, di, OPTIONAL); + ut, BT_INTEGER, di, REQUIRED, INTENT_IN, + vl, BT_INTEGER, di, REQUIRED, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_3s ("lstat", GFC_ISYM_LSTAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_3s ("lstat", GFC_ISYM_LSTAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_stat_sub, NULL, gfc_resolve_lstat_sub, - name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED, - st, BT_INTEGER, di, OPTIONAL); + name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + vl, BT_INTEGER, di, REQUIRED, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_3s ("stat", GFC_ISYM_STAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + add_sym_3s ("stat", GFC_ISYM_STAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_stat_sub, NULL, gfc_resolve_stat_sub, - name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED, - st, BT_INTEGER, di, OPTIONAL); - - add_sym_3s ("signal", GFC_ISYM_SIGNAL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_signal_sub, NULL, gfc_resolve_signal_sub, - num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED, - st, BT_INTEGER, di, OPTIONAL); - - add_sym_3s ("symlnk", GFC_ISYM_SYMLINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub, - p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, - dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); - - add_sym_2s ("system", GFC_ISYM_SYSTEM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - NULL, NULL, gfc_resolve_system_sub, - com, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); - - add_sym_3s_intent ("system_clock", GFC_ISYM_SYSTEM_CLOCK, NO_CLASS, - BT_UNKNOWN, 0, GFC_STD_F95, - gfc_check_system_clock, NULL, gfc_resolve_system_clock, - c, BT_INTEGER, di, OPTIONAL, INTENT_OUT, - cr, BT_INTEGER, di, OPTIONAL, INTENT_OUT, - cm, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_2s ("ttynam", GFC_ISYM_TTYNAM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub, - ut, BT_INTEGER, di, REQUIRED, name, BT_CHARACTER, dc, REQUIRED); - - add_sym_2s ("umask", GFC_ISYM_UMASK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, + name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + vl, BT_INTEGER, di, REQUIRED, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_signal_sub, NULL, gfc_resolve_signal_sub, + num, BT_INTEGER, di, REQUIRED, INTENT_IN, + han, BT_UNKNOWN, 0, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("symlnk", GFC_ISYM_SYMLINK, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub, + p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_2s ("system", GFC_ISYM_SYSTEM, CLASS_IMPURE, BT_UNKNOWN, + 0, GFC_STD_GNU, NULL, NULL, gfc_resolve_system_sub, + com, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("system_clock", GFC_ISYM_SYSTEM_CLOCK, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F95, + gfc_check_system_clock, NULL, gfc_resolve_system_clock, + c, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + cr, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + cm, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_2s ("ttynam", GFC_ISYM_TTYNAM, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub, + ut, BT_INTEGER, di, REQUIRED, INTENT_IN, + name, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); + + add_sym_2s ("umask", GFC_ISYM_UMASK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_umask_sub, NULL, gfc_resolve_umask_sub, - msk, BT_INTEGER, di, REQUIRED, old, BT_INTEGER, di, OPTIONAL); + msk, BT_INTEGER, di, REQUIRED, INTENT_IN, + old, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_2s ("unlink", GFC_ISYM_UNLINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub, - "path", BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + add_sym_2s ("unlink", GFC_ISYM_UNLINK, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub, + "path", BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); } @@ -2940,6 +3163,7 @@ add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard) sym->simplify.cc = gfc_convert_constant; sym->standard = standard; sym->elemental = 1; + sym->pure = 1; sym->conversion = 1; sym->ts = to; sym->id = GFC_ISYM_CONVERSION; @@ -3090,6 +3314,7 @@ add_char_conversions (void) char_conversions[n].simplify.cc = gfc_convert_char_constant; char_conversions[n].standard = GFC_STD_F2003; char_conversions[n].elemental = 1; + char_conversions[n].pure = 1; char_conversions[n].conversion = 0; char_conversions[n].ts = to; char_conversions[n].id = GFC_ISYM_CONVERSION; @@ -3267,7 +3492,7 @@ keywords: if (f->actual != NULL) { - gfc_error ("Argument '%s' is appears twice in call to '%s' at %L", + gfc_error ("Argument '%s' appears twice in call to '%s' at %L", f->name, name, where); return FAILURE; } @@ -3354,7 +3579,7 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym, { if (error_flag) gfc_error ("Type of argument '%s' in call to '%s' at %L should " - "be %s, not %s", gfc_current_intrinsic_arg[i], + "be %s, not %s", gfc_current_intrinsic_arg[i]->name, gfc_current_intrinsic, &actual->expr->where, gfc_typename (&formal->ts), gfc_typename (&actual->expr->ts)); @@ -3573,7 +3798,7 @@ init_arglist (gfc_intrinsic_sym *isym) { if (i >= MAX_INTRINSIC_ARGS) gfc_internal_error ("init_arglist(): too many arguments"); - gfc_current_intrinsic_arg[i++] = formal->name; + gfc_current_intrinsic_arg[i++] = formal; } } @@ -3615,6 +3840,9 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) /* Same here. The difference to the previous case is that we allow a general numeric type. */ t = gfc_check_product_sum (*ap); + else if (specific->check.f3red == gfc_check_transf_bit_intrins) + /* Same as for PRODUCT and SUM, but different checks. */ + t = gfc_check_transf_bit_intrins (*ap); else { if (specific->check.f1 == NULL) @@ -3642,8 +3870,8 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) if (gfc_check_conformance (first_expr, arg->expr, "arguments '%s' and '%s' for " "intrinsic '%s'", - gfc_current_intrinsic_arg[0], - gfc_current_intrinsic_arg[n], + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic) == FAILURE) return FAILURE; } @@ -3781,7 +4009,7 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag) if ((isym->id == GFC_ISYM_REAL || isym->id == GFC_ISYM_DBLE || isym->id == GFC_ISYM_CMPLX) - && gfc_init_expr + && gfc_init_expr_flag && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Function '%s' " "as initialization expression at %L", name, &expr->where) == FAILURE) @@ -3857,7 +4085,7 @@ got_specific: (4) A reference to an elemental standard intrinsic function, where each argument is an initialization expression */ - if (gfc_init_expr && isym->elemental && flag + if (gfc_init_expr_flag && isym->elemental && flag && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Elemental function " "as initialization expression with non-integer/non-" "character arguments at %L", &expr->where) == FAILURE) @@ -3991,11 +4219,75 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag) /* At this point, a conversion is necessary. A warning may be needed. */ if ((gfc_option.warn_std & sym->standard) != 0) - gfc_warning_now ("Extension: Conversion from %s to %s at %L", - gfc_typename (&from_ts), gfc_typename (ts), &expr->where); - else if (wflag && gfc_option.warn_conversion) - gfc_warning_now ("Conversion from %s to %s at %L", - gfc_typename (&from_ts), gfc_typename (ts), &expr->where); + { + gfc_warning_now ("Extension: Conversion from %s to %s at %L", + gfc_typename (&from_ts), gfc_typename (ts), + &expr->where); + } + else if (wflag) + { + if (gfc_option.flag_range_check + && expr->expr_type == EXPR_CONSTANT + && from_ts.type == ts->type) + { + /* Do nothing. Constants of the same type are range-checked + elsewhere. If a value too large for the target type is + assigned, an error is generated. Not checking here avoids + duplications of warnings/errors. + If range checking was disabled, but -Wconversion enabled, + a non range checked warning is generated below. */ + } + else if (from_ts.type == BT_LOGICAL || ts->type == BT_LOGICAL) + { + /* Do nothing. This block exists only to simplify the other + else-if expressions. + LOGICAL <> LOGICAL no warning, independent of kind values + LOGICAL <> INTEGER extension, warned elsewhere + LOGICAL <> REAL invalid, error generated elsewhere + LOGICAL <> COMPLEX invalid, error generated elsewhere */ + } + else if (from_ts.type == ts->type + || (from_ts.type == BT_INTEGER && ts->type == BT_REAL) + || (from_ts.type == BT_INTEGER && ts->type == BT_COMPLEX) + || (from_ts.type == BT_REAL && ts->type == BT_COMPLEX)) + { + /* Larger kinds can hold values of smaller kinds without problems. + Hence, only warn if target kind is smaller than the source + kind - or if -Wconversion-extra is specified. */ + if (gfc_option.warn_conversion_extra) + gfc_warning_now ("Conversion from %s to %s at %L", + gfc_typename (&from_ts), gfc_typename (ts), + &expr->where); + else if (gfc_option.warn_conversion + && from_ts.kind > ts->kind) + gfc_warning_now ("Possible change of value in conversion " + "from %s to %s at %L", gfc_typename (&from_ts), + gfc_typename (ts), &expr->where); + } + else if ((from_ts.type == BT_REAL && ts->type == BT_INTEGER) + || (from_ts.type == BT_COMPLEX && ts->type == BT_INTEGER) + || (from_ts.type == BT_COMPLEX && ts->type == BT_REAL)) + { + /* Conversion from REAL/COMPLEX to INTEGER or COMPLEX to REAL + usually comes with a loss of information, regardless of kinds. */ + if (gfc_option.warn_conversion_extra + || gfc_option.warn_conversion) + gfc_warning_now ("Possible change of value in conversion " + "from %s to %s at %L", gfc_typename (&from_ts), + gfc_typename (ts), &expr->where); + } + else if (from_ts.type == BT_HOLLERITH || ts->type == BT_HOLLERITH) + { + /* If HOLLERITH is involved, all bets are off. */ + if (gfc_option.warn_conversion_extra + || gfc_option.warn_conversion) + gfc_warning_now ("Conversion from %s to %s at %L", + gfc_typename (&from_ts), gfc_typename (ts), + &expr->where); + } + else + gcc_unreachable (); + } /* Insert a pre-resolved function call to the right function. */ old_where = expr->where; diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index b675de25091..9818f7a9f47 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -40,7 +40,9 @@ gfc_try gfc_check_associated (gfc_expr *, gfc_expr *); gfc_try gfc_check_atan_2 (gfc_expr *, gfc_expr *); gfc_try gfc_check_atan2 (gfc_expr *, gfc_expr *); gfc_try gfc_check_besn (gfc_expr *, gfc_expr *); -gfc_try gfc_check_btest (gfc_expr *, gfc_expr *); +gfc_try gfc_check_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_try gfc_check_bge_bgt_ble_blt (gfc_expr *, gfc_expr *); +gfc_try gfc_check_bitfcn (gfc_expr *, gfc_expr *); gfc_try gfc_check_char (gfc_expr *, gfc_expr *); gfc_try gfc_check_chdir (gfc_expr *); gfc_try gfc_check_chmod (gfc_expr *, gfc_expr *); @@ -55,10 +57,12 @@ gfc_try gfc_check_dble (gfc_expr *); gfc_try gfc_check_digits (gfc_expr *); gfc_try gfc_check_dot_product (gfc_expr *, gfc_expr *); gfc_try gfc_check_dprod (gfc_expr *, gfc_expr *); +gfc_try gfc_check_dshift (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_dtime_etime (gfc_expr *); gfc_try gfc_check_fgetputc (gfc_expr *, gfc_expr *); gfc_try gfc_check_fgetput (gfc_expr *); +gfc_try gfc_check_float (gfc_expr *); gfc_try gfc_check_fstat (gfc_expr *, gfc_expr *); gfc_try gfc_check_ftell (gfc_expr *); gfc_try gfc_check_fn_c (gfc_expr *); @@ -73,9 +77,7 @@ gfc_try gfc_check_hypot (gfc_expr *, gfc_expr *); gfc_try gfc_check_i (gfc_expr *); gfc_try gfc_check_iand (gfc_expr *, gfc_expr *); gfc_try gfc_check_and (gfc_expr *, gfc_expr *); -gfc_try gfc_check_ibclr (gfc_expr *, gfc_expr *); gfc_try gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *); -gfc_try gfc_check_ibset (gfc_expr *, gfc_expr *); gfc_try gfc_check_ichar_iachar (gfc_expr *, gfc_expr *); gfc_try gfc_check_idnint (gfc_expr *); gfc_try gfc_check_ieor (gfc_expr *, gfc_expr *); @@ -91,6 +93,7 @@ gfc_try gfc_check_ishftc (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_kill (gfc_expr *, gfc_expr *); gfc_try gfc_check_kind (gfc_expr *); gfc_try gfc_check_lbound (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_try gfc_check_lcobound (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_len_lentrim (gfc_expr *, gfc_expr *); gfc_try gfc_check_link (gfc_expr *, gfc_expr *); gfc_try gfc_check_lge_lgt_lle_llt (gfc_expr *, gfc_expr *); @@ -101,14 +104,18 @@ gfc_try gfc_check_min_max_integer (gfc_actual_arglist *); gfc_try gfc_check_min_max_real (gfc_actual_arglist *); gfc_try gfc_check_min_max_double (gfc_actual_arglist *); gfc_try gfc_check_malloc (gfc_expr *); +gfc_try gfc_check_mask (gfc_expr *, gfc_expr *); gfc_try gfc_check_matmul (gfc_expr *, gfc_expr *); gfc_try gfc_check_merge (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_try gfc_check_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_minloc_maxloc (gfc_actual_arglist *); gfc_try gfc_check_minval_maxval (gfc_actual_arglist *); gfc_try gfc_check_nearest (gfc_expr *, gfc_expr *); gfc_try gfc_check_new_line (gfc_expr *); +gfc_try gfc_check_norm2 (gfc_expr *, gfc_expr *); gfc_try gfc_check_null (gfc_expr *); gfc_try gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_try gfc_check_parity (gfc_expr *, gfc_expr *); gfc_try gfc_check_precision (gfc_expr *); gfc_try gfc_check_present (gfc_expr *); gfc_try gfc_check_product_sum (gfc_actual_arglist *); @@ -126,23 +133,29 @@ gfc_try gfc_check_second_sub (gfc_expr *); gfc_try gfc_check_secnds (gfc_expr *); gfc_try gfc_check_selected_char_kind (gfc_expr *); gfc_try gfc_check_selected_int_kind (gfc_expr *); -gfc_try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *); +gfc_try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_set_exponent (gfc_expr *, gfc_expr *); gfc_try gfc_check_shape (gfc_expr *); +gfc_try gfc_check_shift (gfc_expr *, gfc_expr *); 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_transf_bit_intrins (gfc_actual_arglist *); gfc_try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_transpose (gfc_expr *); gfc_try gfc_check_trim (gfc_expr *); gfc_try gfc_check_ttynam (gfc_expr *); gfc_try gfc_check_ubound (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_try gfc_check_ucobound (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_umask (gfc_expr *); gfc_try gfc_check_unlink (gfc_expr *); gfc_try gfc_check_unpack (gfc_expr *, gfc_expr *, gfc_expr *); @@ -178,6 +191,7 @@ gfc_try gfc_check_fseek_sub (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_ftell_sub (gfc_expr *, gfc_expr *); gfc_try gfc_check_getcwd_sub (gfc_expr *, gfc_expr *); gfc_try gfc_check_hostnm_sub (gfc_expr *, gfc_expr *); +gfc_try gfc_check_image_index (gfc_expr *, gfc_expr *); gfc_try gfc_check_itime_idate (gfc_expr *); gfc_try gfc_check_kill_sub (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_ltime_gmtime (gfc_expr *, gfc_expr *); @@ -189,6 +203,7 @@ gfc_try gfc_check_signal_sub (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_sleep_sub (gfc_expr *); gfc_try gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_system_sub (gfc_expr *, gfc_expr *); +gfc_try gfc_check_this_image (gfc_expr *, gfc_expr *); gfc_try gfc_check_ttynam_sub (gfc_expr *, gfc_expr *); gfc_try gfc_check_umask_sub (gfc_expr *, gfc_expr *); gfc_try gfc_check_unlink_sub (gfc_expr *, gfc_expr *); @@ -217,10 +232,16 @@ gfc_expr *gfc_simplify_atan2 (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_bessel_j0 (gfc_expr *); gfc_expr *gfc_simplify_bessel_j1 (gfc_expr *); gfc_expr *gfc_simplify_bessel_jn (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_bessel_jn2 (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_bessel_y0 (gfc_expr *); gfc_expr *gfc_simplify_bessel_y1 (gfc_expr *); gfc_expr *gfc_simplify_bessel_yn (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_bessel_yn2 (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_bge (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_bgt (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_bit_size (gfc_expr *); +gfc_expr *gfc_simplify_ble (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_blt (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_btest (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ceiling (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_char (gfc_expr *, gfc_expr *); @@ -236,6 +257,8 @@ gfc_expr *gfc_simplify_digits (gfc_expr *); gfc_expr *gfc_simplify_dim (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_dprod (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_dot_product (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_dshiftl (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_dshiftr (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_epsilon (gfc_expr *); gfc_expr *gfc_simplify_erf (gfc_expr *); gfc_expr *gfc_simplify_erfc (gfc_expr *); @@ -249,12 +272,15 @@ gfc_expr *gfc_simplify_gamma (gfc_expr *); gfc_expr *gfc_simplify_huge (gfc_expr *); gfc_expr *gfc_simplify_hypot (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_iachar (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_iall (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_iand (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_iany (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ibclr (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ibits (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ibset (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ichar (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ieor (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_int (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_int2 (gfc_expr *); @@ -263,6 +289,7 @@ gfc_expr *gfc_simplify_long (gfc_expr *); gfc_expr *gfc_simplify_ifix (gfc_expr *); gfc_expr *gfc_simplify_idint (gfc_expr *); gfc_expr *gfc_simplify_ior (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_iparity (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_is_iostat_end (gfc_expr *); gfc_expr *gfc_simplify_is_iostat_eor (gfc_expr *); gfc_expr *gfc_simplify_isnan (gfc_expr *); @@ -270,6 +297,7 @@ gfc_expr *gfc_simplify_ishft (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ishftc (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_kind (gfc_expr *); gfc_expr *gfc_simplify_lbound (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_lcobound (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_leadz (gfc_expr *); gfc_expr *gfc_simplify_len (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_len_trim (gfc_expr *, gfc_expr *); @@ -281,8 +309,12 @@ gfc_expr *gfc_simplify_llt (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_log (gfc_expr *); gfc_expr *gfc_simplify_log10 (gfc_expr *); gfc_expr *gfc_simplify_logical (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_lshift (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_matmul (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_maskl (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_maskr (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_merge (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_min (gfc_expr *); gfc_expr *gfc_simplify_minval (gfc_expr *, gfc_expr*, gfc_expr*); gfc_expr *gfc_simplify_max (gfc_expr *); @@ -296,12 +328,16 @@ gfc_expr *gfc_simplify_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *gfc_simplify_nearest (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_new_line (gfc_expr *); gfc_expr *gfc_simplify_nint (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_norm2 (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_null (gfc_expr *); gfc_expr *gfc_simplify_num_images (void); gfc_expr *gfc_simplify_idnint (gfc_expr *); gfc_expr *gfc_simplify_not (gfc_expr *); gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_pack (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_parity (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_popcnt (gfc_expr *); +gfc_expr *gfc_simplify_poppar (gfc_expr *); gfc_expr *gfc_simplify_precision (gfc_expr *); gfc_expr *gfc_simplify_product (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_radix (gfc_expr *); @@ -312,14 +348,18 @@ gfc_expr *gfc_simplify_repeat (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_rrspacing (gfc_expr *); +gfc_expr *gfc_simplify_rshift (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_scale (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_selected_char_kind (gfc_expr *); gfc_expr *gfc_simplify_selected_int_kind (gfc_expr *); -gfc_expr *gfc_simplify_selected_real_kind (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_set_exponent (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_sign (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_shape (gfc_expr *); +gfc_expr *gfc_simplify_shifta (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_shiftl (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_shiftr (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_sin (gfc_expr *); gfc_expr *gfc_simplify_sinh (gfc_expr *); gfc_expr *gfc_simplify_size (gfc_expr *, gfc_expr *, gfc_expr *); @@ -330,12 +370,14 @@ gfc_expr *gfc_simplify_sqrt (gfc_expr *); gfc_expr *gfc_simplify_sum (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_tan (gfc_expr *); gfc_expr *gfc_simplify_tanh (gfc_expr *); +gfc_expr *gfc_simplify_this_image (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_tiny (gfc_expr *); gfc_expr *gfc_simplify_trailz (gfc_expr *); gfc_expr *gfc_simplify_transfer (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_transpose (gfc_expr *); gfc_expr *gfc_simplify_trim (gfc_expr *); gfc_expr *gfc_simplify_ubound (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_ucobound (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_unpack (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_xor (gfc_expr *, gfc_expr *); @@ -367,6 +409,7 @@ void gfc_resolve_atan (gfc_expr *, gfc_expr *); void gfc_resolve_atanh (gfc_expr *, gfc_expr *); void gfc_resolve_atan2 (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_besn (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *a); void gfc_resolve_btest (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ceiling (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_char (gfc_expr *, gfc_expr *, gfc_expr *); @@ -385,6 +428,7 @@ void gfc_resolve_dble (gfc_expr *, gfc_expr *); void gfc_resolve_dim (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_dot_product (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_dprod (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_dshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_dtime_sub (gfc_code *); void gfc_resolve_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); @@ -414,18 +458,22 @@ void gfc_resolve_iand (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ierrno (gfc_expr *); void gfc_resolve_ieor (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ichar (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_iachar (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_iall (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_iany (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_idnint (gfc_expr *, gfc_expr *); void gfc_resolve_int (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_int2 (gfc_expr *, gfc_expr *); void gfc_resolve_int8 (gfc_expr *, gfc_expr *); void gfc_resolve_long (gfc_expr *, gfc_expr *); void gfc_resolve_ior (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_iparity (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_isatty (gfc_expr *, gfc_expr *); void gfc_resolve_rshift (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_lshift (gfc_expr *, gfc_expr *, gfc_expr *); @@ -433,6 +481,7 @@ void gfc_resolve_ishft (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ishftc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_kill (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_lbound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_lcobound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_len (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_len_trim (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_lgamma (gfc_expr *, gfc_expr *); @@ -449,7 +498,9 @@ void gfc_resolve_maxloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_maxval (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_mclock (gfc_expr *); void gfc_resolve_mclock8 (gfc_expr *); +void gfc_resolve_mask (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_merge (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_min (gfc_expr *, gfc_actual_arglist *); void gfc_resolve_minloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_minval (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); @@ -457,9 +508,11 @@ void gfc_resolve_mod (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_modulo (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_nearest (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_nint (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_norm2 (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_not (gfc_expr *, gfc_expr *); void gfc_resolve_or (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_pack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_parity (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_product (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_real (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_realpart (gfc_expr *, gfc_expr *); @@ -475,6 +528,7 @@ void gfc_resolve_second_sub (gfc_code *); void gfc_resolve_secnds (gfc_expr *, gfc_expr *); void gfc_resolve_set_exponent (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_shape (gfc_expr *, gfc_expr *); +void gfc_resolve_shift (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_sign (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_signal (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_sin (gfc_expr *, gfc_expr *); @@ -484,12 +538,14 @@ 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 *); void gfc_resolve_system (gfc_expr *, gfc_expr *); void gfc_resolve_tan (gfc_expr *, gfc_expr *); void gfc_resolve_tanh (gfc_expr *, gfc_expr *); +void gfc_resolve_this_image (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_time (gfc_expr *); void gfc_resolve_time8 (gfc_expr *); void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); @@ -497,6 +553,7 @@ void gfc_resolve_transpose (gfc_expr *, gfc_expr *); void gfc_resolve_trim (gfc_expr *, gfc_expr *); void gfc_resolve_ttynam (gfc_expr *, gfc_expr *); void gfc_resolve_ubound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_ucobound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_umask (gfc_expr *, gfc_expr *); void gfc_resolve_unlink (gfc_expr *, gfc_expr *); void gfc_resolve_unpack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); @@ -511,6 +568,7 @@ void gfc_resolve_chdir_sub (gfc_code *); void gfc_resolve_chmod_sub (gfc_code *); void gfc_resolve_cpu_time (gfc_code *); void gfc_resolve_ctime_sub (gfc_code *); +void gfc_resolve_execute_command_line (gfc_code *); void gfc_resolve_exit (gfc_code *); void gfc_resolve_fdate_sub (gfc_code *); void gfc_resolve_flush (gfc_code *); @@ -558,5 +616,5 @@ void gfc_resolve_unlink_sub (gfc_code *); #define MAX_INTRINSIC_ARGS 5 extern const char *gfc_current_intrinsic; -extern const char *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; +extern gfc_intrinsic_arg *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; extern locus *gfc_current_intrinsic_where; diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 52992ba0c41..d2b3b94dd38 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -5,7 +5,7 @@ This is part of the GNU Fortran manual. For copying conditions, see the file gfortran.texi. Permission is granted to copy, distribute and/or modify this document -under the terms of the GNU Free Documentation License, Version 1.2 or +under the terms of the GNU Free Documentation License, Version 1.3 or any later version published by the Free Software Foundation; with the Invariant Sections being ``Funding Free Software'', the Front-Cover Texts being (a) (see below), and with the Back-Cover Texts being (b) @@ -44,7 +44,7 @@ Some basic guidelines for editing this document: * @code{ACCESS}: ACCESS, Checks file access modes * @code{ACHAR}: ACHAR, Character in @acronym{ASCII} collating sequence * @code{ACOS}: ACOS, Arccosine function -* @code{ACOSH}: ACOSH, Hyperbolic arccosine function +* @code{ACOSH}: ACOSH, Inverse hyperbolic cosine function * @code{ADJUSTL}: ADJUSTL, Left adjust a string * @code{ADJUSTR}: ADJUSTR, Right adjust a string * @code{AIMAG}: AIMAG, Imaginary part of complex number @@ -56,18 +56,22 @@ Some basic guidelines for editing this document: * @code{ANINT}: ANINT, Nearest whole number * @code{ANY}: ANY, Determine if any values are true * @code{ASIN}: ASIN, Arcsine function -* @code{ASINH}: ASINH, Hyperbolic arcsine function +* @code{ASINH}: ASINH, Inverse hyperbolic sine function * @code{ASSOCIATED}: ASSOCIATED, Status of a pointer or pointer/target pair * @code{ATAN}: ATAN, Arctangent function * @code{ATAN2}: ATAN2, Arctangent function -* @code{ATANH}: ATANH, Hyperbolic arctangent function +* @code{ATANH}: ATANH, Inverse hyperbolic tangent function * @code{BESSEL_J0}: BESSEL_J0, Bessel function of the first kind of order 0 * @code{BESSEL_J1}: BESSEL_J1, Bessel function of the first kind of order 1 * @code{BESSEL_JN}: BESSEL_JN, Bessel function of the first kind * @code{BESSEL_Y0}: BESSEL_Y0, Bessel function of the second kind of order 0 * @code{BESSEL_Y1}: BESSEL_Y1, Bessel function of the second kind of order 1 * @code{BESSEL_YN}: BESSEL_YN, Bessel function of the second kind +* @code{BGE}: BGE, Bitwise greater than or equal to +* @code{BGT}: BGT, Bitwise greater than * @code{BIT_SIZE}: BIT_SIZE, Bit size inquiry function +* @code{BLE}: BLE, Bitwise less than or equal to +* @code{BLT}: BLT, Bitwise less than * @code{BTEST}: BTEST, Bit test function * @code{C_ASSOCIATED}: C_ASSOCIATED, Status of a C pointer * @code{C_F_POINTER}: C_F_POINTER, Convert C into Fortran pointer @@ -92,12 +96,13 @@ Some basic guidelines for editing this document: * @code{DATE_AND_TIME}: DATE_AND_TIME, Date and time subroutine * @code{DBLE}: DBLE, Double precision conversion function * @code{DCMPLX}: DCMPLX, Double complex conversion function -* @code{DFLOAT}: DFLOAT, Double precision conversion function * @code{DIGITS}: DIGITS, Significant digits function * @code{DIM}: DIM, Positive difference * @code{DOT_PRODUCT}: DOT_PRODUCT, Dot product function * @code{DPROD}: DPROD, Double product function * @code{DREAL}: DREAL, Double real part function +* @code{DSHIFTL}: DSHIFTL, Combined left shift +* @code{DSHIFTR}: DSHIFTR, Combined right shift * @code{DTIME}: DTIME, Execution time subroutine (or function) * @code{EOSHIFT}: EOSHIFT, End-off shift elements of an array * @code{EPSILON}: EPSILON, Epsilon function @@ -105,13 +110,14 @@ Some basic guidelines for editing this document: * @code{ERFC}: ERFC, Complementary error function * @code{ERFC_SCALED}: ERFC_SCALED, Exponentially-scaled complementary error function * @code{ETIME}: ETIME, Execution time subroutine (or function) +* @code{EXECUTE_COMMAND_LINE}: EXECUTE_COMMAND_LINE, Execute a shell command * @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 -* @code{FLOAT}: FLOAT, Convert integer to default real * @code{FLOOR}: FLOOR, Integer floor function * @code{FLUSH}: FLUSH, Flush I/O unit(s) * @code{FNUM}: FNUM, File number function @@ -139,7 +145,9 @@ Some basic guidelines for editing this document: * @code{HUGE}: HUGE, Largest number of a kind * @code{HYPOT}: HYPOT, Euclidian distance function * @code{IACHAR}: IACHAR, Code in @acronym{ASCII} collating sequence +* @code{IALL}: IALL, Bitwise AND of array elements * @code{IAND}: IAND, Bitwise logical and +* @code{IANY}: IANY, Bitwise OR of array elements * @code{IARGC}: IARGC, Get the number of command line arguments * @code{IBCLR}: IBCLR, Clear bit * @code{IBITS}: IBITS, Bit extraction @@ -148,11 +156,13 @@ Some basic guidelines for editing this document: * @code{IDATE}: IDATE, Current local time (day/month/year) * @code{IEOR}: IEOR, Bitwise logical exclusive or * @code{IERRNO}: IERRNO, Function to get the last system error number +* @code{IMAGE_INDEX}: IMAGE_INDEX, Cosubscript to image index convertion * @code{INDEX}: INDEX intrinsic, Position of a substring within a string * @code{INT}: INT, Convert to integer type * @code{INT2}: INT2, Convert to 16-bit integer type * @code{INT8}: INT8, Convert to 64-bit integer type * @code{IOR}: IOR, Bitwise logical or +* @code{IPARITY}: IPARITY, Bitwise XOR of array elements * @code{IRAND}: IRAND, Integer pseudo-random number * @code{IS_IOSTAT_END}: IS_IOSTAT_END, Test for end-of-file value * @code{IS_IOSTAT_EOR}: IS_IOSTAT_EOR, Test for end-of-record value @@ -164,6 +174,7 @@ Some basic guidelines for editing this document: * @code{KILL}: KILL, Send a signal to a process * @code{KIND}: KIND, Kind of an entity * @code{LBOUND}: LBOUND, Lower dimension bounds of an array +* @code{LCOBOUND}: LCOBOUND, Lower codimension bounds of an array * @code{LEADZ}: LEADZ, Number of leading zero bits of an integer * @code{LEN}: LEN, Length of a character entity * @code{LEN_TRIM}: LEN_TRIM, Length of a character entity without trailing blank characters @@ -183,6 +194,8 @@ Some basic guidelines for editing this document: * @code{LSTAT}: LSTAT, Get file status * @code{LTIME}: LTIME, Convert time to local time info * @code{MALLOC}: MALLOC, Dynamic memory allocation function +* @code{MASKL}: MASKL, Left justified mask +* @code{MASKR}: MASKR, Right justified mask * @code{MATMUL}: MATMUL, matrix multiplication * @code{MAX}: MAX, Maximum value of an argument list * @code{MAXEXPONENT}: MAXEXPONENT, Maximum exponent of a real kind @@ -191,6 +204,7 @@ Some basic guidelines for editing this document: * @code{MCLOCK}: MCLOCK, Time function * @code{MCLOCK8}: MCLOCK8, Time function (64-bit) * @code{MERGE}: MERGE, Merge arrays +* @code{MERGE_BITS}: MERGE_BITS, Merge of bits under mask * @code{MIN}: MIN, Minimum value of an argument list * @code{MINEXPONENT}: MINEXPONENT, Minimum exponent of a real kind * @code{MINLOC}: MINLOC, Location of the minimum value within an array @@ -202,12 +216,16 @@ Some basic guidelines for editing this document: * @code{NEAREST}: NEAREST, Nearest representable number * @code{NEW_LINE}: NEW_LINE, New line character * @code{NINT}: NINT, Nearest whole number +* @code{NORM2}: NORM2, Euclidean vector norm * @code{NOT}: NOT, Logical negation * @code{NULL}: NULL, Function that returns an disassociated pointer * @code{NUM_IMAGES}: NUM_IMAGES, Number of images * @code{OR}: OR, Bitwise logical OR * @code{PACK}: PACK, Pack an array into an array of rank one +* @code{PARITY}: PARITY, Reduction with exclusive OR * @code{PERROR}: PERROR, Print system error message +* @code{POPCNT}: POPCNT, Number of bits set +* @code{POPPAR}: POPPAR, Parity of the number of bits set * @code{PRECISION}: PRECISION, Decimal precision of a real kind * @code{PRESENT}: PRESENT, Determine whether an optional dummy argument is specified * @code{PRODUCT}: PRODUCT, Product of array elements @@ -223,6 +241,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 @@ -232,6 +251,9 @@ Some basic guidelines for editing this document: * @code{SELECTED_REAL_KIND}: SELECTED_REAL_KIND, Choose real kind * @code{SET_EXPONENT}: SET_EXPONENT, Set the exponent of the model * @code{SHAPE}: SHAPE, Determine the shape of an array +* @code{SHIFTA}: SHIFTA, Right shift with fill +* @code{SHIFTL}: SHIFTL, Left shift +* @code{SHIFTR}: SHIFTR, Right shift * @code{SIGN}: SIGN, Sign copying function * @code{SIGNAL}: SIGNAL, Signal handling subroutine (or function) * @code{SIN}: SIN, Sine function @@ -239,18 +261,19 @@ Some basic guidelines for editing this document: * @code{SIZE}: SIZE, Function to determine the size of an array * @code{SIZEOF}: SIZEOF, Determine the size in bytes of an expression * @code{SLEEP}: SLEEP, Sleep for the specified number of seconds -* @code{SNGL}: SNGL, Convert double precision real to default real * @code{SPACING}: SPACING, Smallest distance between two numbers of a given type * @code{SPREAD}: SPREAD, Add a dimension to an array * @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 * @code{SYSTEM_CLOCK}: SYSTEM_CLOCK, Time function * @code{TAN}: TAN, Tangent function * @code{TANH}: TANH, Hyperbolic tangent function +* @code{THIS_IMAGE}: THIS_IMAGE, Cosubscript index of this image * @code{TIME}: TIME, Time function * @code{TIME8}: TIME8, Time function (64-bit) * @code{TINY}: TINY, Smallest positive number of a real kind @@ -260,6 +283,7 @@ Some basic guidelines for editing this document: * @code{TRIM}: TRIM, Remove trailing blank characters of a string * @code{TTYNAM}: TTYNAM, Get the name of a terminal device. * @code{UBOUND}: UBOUND, Upper dimension bounds of an array +* @code{UCOBOUND}: UCOBOUND, Upper codimension bounds of an array * @code{UMASK}: UMASK, Set the file creation mask * @code{UNLINK}: UNLINK, Remove a file from the file system * @code{UNPACK}: UNPACK, Unpack an array of rank one into an array @@ -400,11 +424,12 @@ end program test_abs @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{CABS(A)} @tab @code{COMPLEX(4) Z} @tab @code{REAL(4)} @tab Fortran 77 and later -@item @code{DABS(A)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later -@item @code{IABS(A)} @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)} @tab Fortran 77 and later -@item @code{ZABS(A)} @tab @code{COMPLEX(8) Z} @tab @code{COMPLEX(8)} @tab GNU extension -@item @code{CDABS(A)} @tab @code{COMPLEX(8) Z} @tab @code{COMPLEX(8)} @tab GNU extension +@item @code{ABS(A)} @tab @code{REAL(4) A} @tab @code{REAL(4)} @tab Fortran 77 and later +@item @code{CABS(A)} @tab @code{COMPLEX(4) A} @tab @code{REAL(4)} @tab Fortran 77 and later +@item @code{DABS(A)} @tab @code{REAL(8) A} @tab @code{REAL(8)} @tab Fortran 77 and later +@item @code{IABS(A)} @tab @code{INTEGER(4) A} @tab @code{INTEGER(4)} @tab Fortran 77 and later +@item @code{ZABS(A)} @tab @code{COMPLEX(8) A} @tab @code{COMPLEX(8)} @tab GNU extension +@item @code{CDABS(A)} @tab @code{COMPLEX(8) A} @tab @code{COMPLEX(8)} @tab GNU extension @end multitable @end table @@ -561,8 +586,9 @@ end program test_acos @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard -@item @code{DACOS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later +@item Name @tab Argument @tab Return type @tab Standard +@item @code{ACOS(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later +@item @code{DACOS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @item @emph{See also}: @@ -573,18 +599,17 @@ Inverse function: @ref{COS} @node ACOSH -@section @code{ACOSH} --- Hyperbolic arccosine function +@section @code{ACOSH} --- Inverse hyperbolic cosine function @fnindex ACOSH @fnindex DACOSH @cindex area hyperbolic cosine -@cindex hyperbolic arccosine +@cindex inverse hyperbolic cosine @cindex hyperbolic function, cosine, inverse @cindex cosine, hyperbolic, inverse @table @asis @item @emph{Description}: -@code{ACOSH(X)} computes the hyperbolic arccosine of @var{X} (inverse of -@code{COSH(X)}). +@code{ACOSH(X)} computes the inverse hyperbolic cosine of @var{X}. @item @emph{Standard}: Fortran 2008 and later @@ -761,10 +786,11 @@ end program test_aimag @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard -@item @code{DIMAG(Z)} @tab @code{COMPLEX(8) Z} @tab @code{REAL(8)} @tab GNU extension -@item @code{IMAG(Z)} @tab @code{COMPLEX Z} @tab @code{REAL} @tab GNU extension -@item @code{IMAGPART(Z)} @tab @code{COMPLEX Z} @tab @code{REAL} @tab GNU extension +@item Name @tab Argument @tab Return type @tab Standard +@item @code{AIMAG(Z)} @tab @code{COMPLEX Z} @tab @code{REAL} @tab GNU extension +@item @code{DIMAG(Z)} @tab @code{COMPLEX(8) Z} @tab @code{REAL(8)} @tab GNU extension +@item @code{IMAG(Z)} @tab @code{COMPLEX Z} @tab @code{REAL} @tab GNU extension +@item @code{IMAGPART(Z)} @tab @code{COMPLEX Z} @tab @code{REAL} @tab GNU extension @end multitable @end table @@ -821,7 +847,8 @@ end program test_aint @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard -@item @code{DINT(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later +@item @code{AINT(A)} @tab @code{REAL(4) A} @tab @code{REAL(4)} @tab Fortran 77 and later +@item @code{DINT(A)} @tab @code{REAL(8) A} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @end table @@ -952,26 +979,29 @@ end program test_all @table @asis @item @emph{Description}: -@code{ALLOCATED(ARRAY)} checks the status of whether @var{X} is allocated. +@code{ALLOCATED(ARRAY)} and @code{ALLOCATED(SCALAR)} check the allocation +status of @var{ARRAY} and @var{SCALAR}, respectively. @item @emph{Standard}: -Fortran 95 and later +Fortran 95 and later. Note, the @code{SCALAR=} keyword and allocatable +scalar entities are available in Fortran 2003 and later. @item @emph{Class}: Inquiry function @item @emph{Syntax}: -@code{RESULT = ALLOCATED(ARRAY)} +@code{RESULT = ALLOCATED(ARRAY)} or @code{RESULT = ALLOCATED(SCALAR)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{ARRAY} @tab The argument shall be an @code{ALLOCATABLE} array. +@item @var{SCALAR} @tab The argument shall be an @code{ALLOCATABLE} scalar. @end multitable @item @emph{Return value}: The return value is a scalar @code{LOGICAL} with the default logical -kind type parameter. If @var{ARRAY} is allocated, @code{ALLOCATED(ARRAY)} -is @code{.TRUE.}; otherwise, it returns @code{.FALSE.} +kind type parameter. If the argument is allocated, then the result is +@code{.TRUE.}; otherwise, it returns @code{.FALSE.} @item @emph{Example}: @smallexample @@ -1088,6 +1118,7 @@ end program test_anint @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard +@item @code{AINT(A)} @tab @code{REAL(4) A} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DNINT(A)} @tab @code{REAL(8) A} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @end table @@ -1203,6 +1234,7 @@ end program test_asin @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard +@item @code{ASIN(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DASIN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @@ -1214,17 +1246,17 @@ Inverse function: @ref{SIN} @node ASINH -@section @code{ASINH} --- Hyperbolic arcsine function +@section @code{ASINH} --- Inverse hyperbolic sine function @fnindex ASINH @fnindex DASINH @cindex area hyperbolic sine -@cindex hyperbolic arcsine +@cindex inverse hyperbolic sine @cindex hyperbolic function, sine, inverse @cindex sine, hyperbolic, inverse @table @asis @item @emph{Description}: -@code{ASINH(X)} computes the hyperbolic arcsine of @var{X} (inverse of @code{SINH(X)}). +@code{ASINH(X)} computes the inverse hyperbolic sine of @var{X}. @item @emph{Standard}: Fortran 2008 and later @@ -1389,6 +1421,7 @@ end program test_atan @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard +@item @code{ATAN(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DATAN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @@ -1448,26 +1481,26 @@ end program test_atan2 @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard -@item @code{DATAN2(X, Y)} @tab @code{REAL(8) X}, @code{REAL(8) Y} @tab @code{REAL(8)} @tab Fortran 77 and later +@item Name @tab Argument @tab Return type @tab Standard +@item @code{ATAN2(X, Y)} @tab @code{REAL(4) X, Y} @tab @code{REAL(4)} @tab Fortran 77 and later +@item @code{DATAN2(X, Y)} @tab @code{REAL(8) X, Y} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @end table @node ATANH -@section @code{ATANH} --- Hyperbolic arctangent function -@fnindex ASINH -@fnindex DASINH +@section @code{ATANH} --- Inverse hyperbolic tangent function +@fnindex ATANH +@fnindex DATANH @cindex area hyperbolic tangent -@cindex hyperbolic arctangent +@cindex inverse hyperbolic tangent @cindex hyperbolic function, tangent, inverse @cindex tangent, hyperbolic, inverse @table @asis @item @emph{Description}: -@code{ATANH(X)} computes the hyperbolic arctangent of @var{X} (inverse -of @code{TANH(X)}). +@code{ATANH(X)} computes the inverse hyperbolic tangent of @var{X}. @item @emph{Standard}: Fortran 2008 and later @@ -1599,8 +1632,8 @@ end program test_besj1 @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard -@item @code{DBESJ1(X)}@tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension +@item Name @tab Argument @tab Return type @tab Standard +@item @code{DBESJ1(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension @end multitable @end table @@ -1617,29 +1650,41 @@ end program test_besj1 @item @emph{Description}: @code{BESSEL_JN(N, X)} computes the Bessel function of the first kind of order @var{N} of @var{X}. This function is available under the name -@code{BESJN} as a GNU extension. +@code{BESJN} as a GNU extension. If @var{N} and @var{X} are arrays, +their ranks and shapes shall conform. -If both arguments are arrays, their ranks and shapes shall conform. +@code{BESSEL_JN(N1, N2, X)} returns an array with the Bessel functions +of the first kind of the orders @var{N1} to @var{N2}. @item @emph{Standard}: -Fortran 2008 and later +Fortran 2008 and later, negative @var{N} is allowed as GNU extension @item @emph{Class}: -Elemental function +Elemental function, except for the tranformational function +@code{BESSEL_JN(N1, N2, X)} @item @emph{Syntax}: @code{RESULT = BESSEL_JN(N, X)} +@code{RESULT = BESSEL_JN(N1, N2, X)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{N} @tab Shall be a scalar or an array of type @code{INTEGER}. -@item @var{X} @tab Shall be a scalar or an array of type @code{REAL}. +@item @var{N1} @tab Shall be a non-negative scalar of type @code{INTEGER}. +@item @var{N2} @tab Shall be a non-negative scalar of type @code{INTEGER}. +@item @var{X} @tab Shall be a scalar or an array of type @code{REAL}; +for @code{BESSEL_JN(N1, N2, X)} it shall be scalar. @end multitable @item @emph{Return value}: The return value is a scalar of type @code{REAL}. It has the same kind as @var{X}. +@item @emph{Note}: +The transformational function uses a recurrence algorithm which might, +for some values of @var{X}, lead to different results than calls to +the elemental function. + @item @emph{Example}: @smallexample program test_besjn @@ -1765,29 +1810,41 @@ end program test_besy1 @item @emph{Description}: @code{BESSEL_YN(N, X)} computes the Bessel function of the second kind of order @var{N} of @var{X}. This function is available under the name -@code{BESYN} as a GNU extension. +@code{BESYN} as a GNU extension. If @var{N} and @var{X} are arrays, +their ranks and shapes shall conform. -If both arguments are arrays, their ranks and shapes shall conform. +@code{BESSEL_YN(N1, N2, X)} returns an array with the Bessel functions +of the first kind of the orders @var{N1} to @var{N2}. @item @emph{Standard}: -Fortran 2008 and later +Fortran 2008 and later, negative @var{N} is allowed as GNU extension @item @emph{Class}: -Elemental function +Elemental function, except for the tranformational function +@code{BESSEL_YN(N1, N2, X)} @item @emph{Syntax}: @code{RESULT = BESSEL_YN(N, X)} +@code{RESULT = BESSEL_YN(N1, N2, X)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{N} @tab Shall be a scalar or an array of type @code{INTEGER}. -@item @var{X} @tab Shall be a scalar or an array of type @code{REAL}. +@item @var{N} @tab Shall be a scalar or an array of type @code{INTEGER} . +@item @var{N1} @tab Shall be a non-negative scalar of type @code{INTEGER}. +@item @var{N2} @tab Shall be a non-negative scalar of type @code{INTEGER}. +@item @var{X} @tab Shall be a scalar or an array of type @code{REAL}; +for @code{BESSEL_YN(N1, N2, X)} it shall be scalar. @end multitable @item @emph{Return value}: The return value is a scalar of type @code{REAL}. It has the same kind as @var{X}. +@item @emph{Note}: +The transformational function uses a recurrence algorithm which might, +for some values of @var{X}, lead to different results than calls to +the elemental function. + @item @emph{Example}: @smallexample program test_besyn @@ -1800,12 +1857,81 @@ end program test_besyn @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard @item @code{DBESYN(N,X)} @tab @code{INTEGER N} @tab @code{REAL(8)} @tab GNU extension -@item @tab @code{REAL(8) X} @tab @tab +@item @tab @code{REAL(8) X} @tab @tab @end multitable @end table +@node BGE +@section @code{BGE} --- Bitwise greater than or equal to +@fnindex BGE +@cindex bitwise comparison + +@table @asis +@item @emph{Description}: +Determines whether an integral is a bitwise greater than or equal to +another. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = BGE(I, J)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{I} @tab Shall be of @code{INTEGER} type. +@item @var{J} @tab Shall be of @code{INTEGER} type, and of the same kind +as @var{I}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{LOGICAL} and of the default kind. + +@item @emph{See also}: +@ref{BGT}, @ref{BLE}, @ref{BLT} +@end table + + + +@node BGT +@section @code{BGT} --- Bitwise greater than +@fnindex BGT +@cindex bitwise comparison + +@table @asis +@item @emph{Description}: +Determines whether an integral is a bitwise greater than another. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = BGT(I, J)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{I} @tab Shall be of @code{INTEGER} type. +@item @var{J} @tab Shall be of @code{INTEGER} type, and of the same kind +as @var{I}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{LOGICAL} and of the default kind. + +@item @emph{See also}: +@ref{BGE}, @ref{BLE}, @ref{BLT} +@end table + + + @node BIT_SIZE @section @code{BIT_SIZE} --- Bit size inquiry function @fnindex BIT_SIZE @@ -1848,6 +1974,75 @@ end program test_bit_size +@node BLE +@section @code{BLE} --- Bitwise less than or equal to +@fnindex BLE +@cindex bitwise comparison + +@table @asis +@item @emph{Description}: +Determines whether an integral is a bitwise less than or equal to +another. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = BLE(I, J)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{I} @tab Shall be of @code{INTEGER} type. +@item @var{J} @tab Shall be of @code{INTEGER} type, and of the same kind +as @var{I}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{LOGICAL} and of the default kind. + +@item @emph{See also}: +@ref{BGT}, @ref{BGE}, @ref{BLT} +@end table + + + +@node BLT +@section @code{BLT} --- Bitwise less than +@fnindex BLT +@cindex bitwise comparison + +@table @asis +@item @emph{Description}: +Determines whether an integral is a bitwise less than another. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = BLT(I, J)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{I} @tab Shall be of @code{INTEGER} type. +@item @var{J} @tab Shall be of @code{INTEGER} type, and of the same kind +as @var{I}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{LOGICAL} and of the default kind. + +@item @emph{See also}: +@ref{BGE}, @ref{BGT}, @ref{BLE} +@end table + + + @node BTEST @section @code{BTEST} --- Bit test function @fnindex BTEST @@ -2127,9 +2322,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}: @@ -2175,7 +2370,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}: @@ -2199,7 +2394,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 @@ -2288,6 +2483,12 @@ program test_char end program test_char @end smallexample +@item @emph{Specific names}: +@multitable @columnfractions .20 .20 .20 .25 +@item Name @tab Argument @tab Return type @tab Standard +@item @code{CHAR(I)} @tab @code{INTEGER I} @tab @code{CHARACTER(LEN=1)} @tab F77 and later +@end multitable + @item @emph{Note}: See @ref{ICHAR} for a discussion of converting between numerical values and formatted string representations. @@ -2611,8 +2812,9 @@ end program test_conjg @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard -@item @code{DCONJG(Z)} @tab @code{COMPLEX(8) Z} @tab @code{COMPLEX(8)} @tab GNU extension +@item Name @tab Argument @tab Return type @tab Standard +@item @code{CONJG(Z)} @tab @code{COMPLEX Z} @tab @code{COMPLEX} @tab GNU extension +@item @code{DCONJG(Z)} @tab @code{COMPLEX(8) Z} @tab @code{COMPLEX(8)} @tab GNU extension @end multitable @end table @@ -2663,6 +2865,7 @@ end program test_cos @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard +@item @code{COS(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DCOS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @item @code{CCOS(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab Fortran 77 and later @item @code{ZCOS(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab GNU extension @@ -2719,6 +2922,7 @@ end program test_cosh @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard +@item @code{COSH(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DCOSH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @@ -3078,7 +3282,7 @@ end program test_dble @end smallexample @item @emph{See also}: -@ref{DFLOAT}, @ref{FLOAT}, @ref{REAL} +@ref{REAL} @end table @@ -3132,47 +3336,6 @@ end program test_dcmplx @end table - -@node DFLOAT -@section @code{DFLOAT} --- Double conversion function -@fnindex DFLOAT -@cindex conversion, to real - -@table @asis -@item @emph{Description}: -@code{DFLOAT(A)} Converts @var{A} to double precision real type. - -@item @emph{Standard}: -GNU extension - -@item @emph{Class}: -Elemental function - -@item @emph{Syntax}: -@code{RESULT = DFLOAT(A)} - -@item @emph{Arguments}: -@multitable @columnfractions .15 .70 -@item @var{A} @tab The type shall be @code{INTEGER}. -@end multitable - -@item @emph{Return value}: -The return value is of type double precision real. - -@item @emph{Example}: -@smallexample -program test_dfloat - integer :: i = 5 - print *, dfloat(i) -end program test_dfloat -@end smallexample - -@item @emph{See also}: -@ref{DBLE}, @ref{FLOAT}, @ref{REAL} -@end table - - - @node DIGITS @section @code{DIGITS} --- Significant binary digits function @fnindex DIGITS @@ -3260,9 +3423,10 @@ end program test_dim @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard -@item @code{IDIM(X,Y)} @tab @code{INTEGER(4) X,Y} @tab @code{INTEGER(4)} @tab Fortran 77 and later -@item @code{DDIM(X,Y)} @tab @code{REAL(8) X,Y} @tab @code{REAL(8)} @tab Fortran 77 and later +@item Name @tab Argument @tab Return type @tab Standard +@item @code{DIM(X,Y)} @tab @code{REAL(4) X, Y} @tab @code{REAL(4)} @tab Fortran 77 and later +@item @code{IDIM(X,Y)} @tab @code{INTEGER(4) X, Y} @tab @code{INTEGER(4)} @tab Fortran 77 and later +@item @code{DDIM(X,Y)} @tab @code{REAL(8) X, Y} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @end table @@ -3359,8 +3523,14 @@ program test_dprod print *, d end program test_dprod @end smallexample -@end table +@item @emph{Specific names}: +@multitable @columnfractions .20 .20 .20 .25 +@item Name @tab Argument @tab Return type @tab Standard +@item @code{DPROD(X,Y)} @tab @code{REAL(4) X, Y} @tab @code{REAL(4)} @tab Fortran 77 and later +@end multitable + +@end table @node DREAL @@ -3404,6 +3574,86 @@ end program test_dreal +@node DSHIFTL +@section @code{DSHIFTL} --- Combined left shift +@fnindex DSHIFTL +@cindex left shift, combined +@cindex shift, left + +@table @asis +@item @emph{Description}: +@code{DSHIFTL(I, J, SHIFT)} combines bits of @var{I} and @var{J}. The +rightmost @var{SHIFT} bits of the result are the leftmost @var{SHIFT} +bits of @var{J}, and the remaining bits are the rightmost bits of +@var{I}. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = DSHIFTL(I, J, SHIFT)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{I} @tab Shall be of type @code{INTEGER}. +@item @var{J} @tab Shall be of type @code{INTEGER}, and of the same kind +as @var{I}. +@item @var{SHIFT} @tab Shall be of type @code{INTEGER}. +@end multitable + +@item @emph{Return value}: +The return value has same type and kind as @var{I}. + +@item @emph{See also}: +@ref{DSHIFTR} + +@end table + + + +@node DSHIFTR +@section @code{DSHIFTR} --- Combined right shift +@fnindex DSHIFTR +@cindex right shift, combined +@cindex shift, right + +@table @asis +@item @emph{Description}: +@code{DSHIFTR(I, J, SHIFT)} combines bits of @var{I} and @var{J}. The +leftmost @var{SHIFT} bits of the result are the rightmost @var{SHIFT} +bits of @var{I}, and the remaining bits are the leftmost bits of +@var{J}. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = DSHIFTR(I, J, SHIFT)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{I} @tab Shall be of type @code{INTEGER}. +@item @var{J} @tab Shall be of type @code{INTEGER}, and of the same kind +as @var{I}. +@item @var{SHIFT} @tab Shall be of type @code{INTEGER}. +@end multitable + +@item @emph{Return value}: +The return value has same type and kind as @var{I}. + +@item @emph{See also}: +@ref{DSHIFTL} + +@end table + + + @node DTIME @section @code{DTIME} --- Execution time subroutine (or function) @fnindex DTIME @@ -3801,6 +4051,82 @@ end program test_etime +@node EXECUTE_COMMAND_LINE +@section @code{EXECUTE_COMMAND_LINE} --- Execute a shell command +@fnindex EXECUTE_COMMAND_LINE +@cindex system, system call +@cindex command line + +@table @asis +@item @emph{Description}: +@code{EXECUTE_COMMAND_LINE} runs a shell command, synchronously or +asynchronously. + +The @code{COMMAND} argument is passed to the shell and executed, using +the C library's @code{system()} call. (The shell is @code{sh} on Unix +systems, and @code{cmd.exe} on Windows.) If @code{WAIT} is present and +has the value false, the execution of the command is asynchronous if the +system supports it; otherwise, the command is executed synchronously. + +The three last arguments allow the user to get status information. After +synchronous execution, @code{EXITSTAT} contains the integer exit code of +the command, as returned by @code{system}. @code{CMDSTAT} is set to zero +if the command line was executed (whatever its exit status was). +@code{CMDMSG} is assigned an error message if an error has occurred. + + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Subroutine + +@item @emph{Syntax}: +@code{CALL EXECUTE_COMMAND_LINE(COMMAND [, WAIT, EXITSTAT, CMDSTAT, CMDMSG ])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{COMMAND} @tab Shall be a default @code{CHARACTER} scalar. +@item @var{WAIT} @tab (Optional) Shall be a default @code{LOGICAL} scalar. +@item @var{EXITSTAT} @tab (Optional) Shall be an @code{INTEGER} of the +default kind. +@item @var{CMDSTAT} @tab (Optional) Shall be an @code{INTEGER} of the +default kind. +@item @var{CMDMSG} @tab (Optional) Shall be an @code{CHARACTER} scalar of the +default kind. +@end multitable + +@item @emph{Example}: +@smallexample +program test_exec + integer :: i + + call execute_command_line ("external_prog.exe", exitstat=i) + print *, "Exit status of external_prog.exe was ", i + + call execute_command_line ("reindex_files.exe", wait=.false.) + print *, "Now reindexing files in the background" + +end program test_exec +@end smallexample + + +@item @emph{Note}: + +Because this intrinsic is implemented in terms of the @code{system()} +function call, its behavior with respect to signalling is processor +dependent. In particular, on POSIX-compliant systems, the SIGINT and +SIGQUIT signals will be ignored, and the SIGCHLD will be blocked. As +such, if the parent process is terminated, the child process might not be +terminated alongside. + + +@item @emph{See also}: +@ref{SYSTEM} +@end table + + + @node EXIT @section @code{EXIT} --- Exit the program with status. @fnindex EXIT @@ -3888,6 +4214,7 @@ end program test_exp @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard +@item @code{EXP(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later @item @code{DEXP(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later @item @code{CEXP(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab Fortran 77 and later @item @code{ZEXP(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab GNU extension @@ -3939,6 +4266,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 @@ -3998,46 +4361,6 @@ end program test_fdate -@node FLOAT -@section @code{FLOAT} --- Convert integer to default real -@fnindex FLOAT -@cindex conversion, to real - -@table @asis -@item @emph{Description}: -@code{FLOAT(A)} converts the integer @var{A} to a default real value. - -@item @emph{Standard}: -Fortran 77 and later - -@item @emph{Class}: -Elemental function - -@item @emph{Syntax}: -@code{RESULT = FLOAT(A)} - -@item @emph{Arguments}: -@multitable @columnfractions .15 .70 -@item @var{A} @tab The type shall be @code{INTEGER}. -@end multitable - -@item @emph{Return value}: -The return value is of type default @code{REAL}. - -@item @emph{Example}: -@smallexample -program test_float - integer :: i = 1 - if (float(i) /= 1.) call abort -end program test_float -@end smallexample - -@item @emph{See also}: -@ref{DBLE}, @ref{DFLOAT}, @ref{REAL} -@end table - - - @node FGET @section @code{FGET} --- Read a single character in stream mode from stdin @fnindex FGET @@ -4066,7 +4389,10 @@ GNU extension Subroutine, function @item @emph{Syntax}: -@code{CALL FGET(C [, STATUS])} +@multitable @columnfractions .80 +@item @code{CALL FGET(C [, STATUS])} +@item @code{STATUS = FGET(C)} +@end multitable @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -4128,7 +4454,10 @@ GNU extension Subroutine, function @item @emph{Syntax}: -@code{CALL FGETC(UNIT, C [, STATUS])} +@multitable @columnfractions .80 +@item @code{CALL FGETC(UNIT, C [, STATUS])} +@item @code{STATUS = FGETC(UNIT, C)} +@end multitable @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -4237,6 +4566,44 @@ Subroutine Beginning with the Fortran 2003 standard, there is a @code{FLUSH} statement that should be preferred over the @code{FLUSH} intrinsic. +The @code{FLUSH} intrinsic and the Fortran 2003 @code{FLUSH} statement +have identical effect: they flush the runtime library's I/O buffer so +that the data becomes visible to other processes. This does not guarantee +that the data is committed to disk. + +On POSIX systems, you can request that all data is transferred to the +storage device by calling the @code{fsync} function, with the POSIX file +descriptor of the I/O unit as argument (retrieved with GNU intrinsic +@code{FNUM}). The following example shows how: + +@smallexample + ! Declare the interface for POSIX fsync function + interface + function fsync (fd) bind(c,name="fsync") + use iso_c_binding, only: c_int + integer(c_int), value :: fd + integer(c_int) :: fsync + end function fsync + end interface + + ! Variable declaration + integer :: ret + + ! Opening unit 10 + open (10,file="foo") + + ! ... + ! Perform I/O on unit 10 + ! ... + + ! Flush and sync + flush(10) + ret = fsync(fnum(10)) + + ! Handle possible error + if (ret /= 0) stop "Error calling FSYNC" +@end smallexample + @end table @@ -4310,7 +4677,10 @@ GNU extension Subroutine, function @item @emph{Syntax}: -@code{CALL FPUT(C [, STATUS])} +@multitable @columnfractions .80 +@item @code{CALL FPUT(C [, STATUS])} +@item @code{STATUS = FPUT(C)} +@end multitable @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -4366,7 +4736,10 @@ GNU extension Subroutine, function @item @emph{Syntax}: -@code{CALL FPUTC(UNIT, C [, STATUS])} +@multitable @columnfractions .80 +@item @code{CALL FPUTC(UNIT, C [, STATUS])} +@item @code{STATUS = FPUTC(UNIT, C)} +@end multitable @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -4584,7 +4957,10 @@ GNU extension Subroutine, function @item @emph{Syntax}: -@code{CALL FSTAT(UNIT, VALUES [, STATUS])} +@multitable @columnfractions .80 +@item @code{CALL FSTAT(UNIT, VALUES [, STATUS])} +@item @code{STATUS = FSTAT(UNIT, VALUES)} +@end multitable @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -4952,7 +5328,10 @@ GNU extension Subroutine, function @item @emph{Syntax}: -@code{CALL GETCWD(C [, STATUS])} +@multitable @columnfractions .80 +@item @code{CALL GETCWD(C [, STATUS])} +@item @code{STATUS = GETCWD(C)} +@end multitable @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -5452,6 +5831,66 @@ and formatted string representations. +@node IALL +@section @code{IALL} --- Bitwise AND of array elements +@fnindex IALL +@cindex array, AND +@cindex bits, AND of array elements + +@table @asis +@item @emph{Description}: +Reduces with bitwise AND the elements of @var{ARRAY} along dimension @var{DIM} +if the corresponding element in @var{MASK} is @code{TRUE}. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Transformational function + +@item @emph{Syntax}: +@multitable @columnfractions .80 +@item @code{RESULT = IALL(ARRAY[, MASK])} +@item @code{RESULT = IALL(ARRAY, DIM[, MASK])} +@end multitable + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER} +@item @var{DIM} @tab (Optional) shall be a scalar of type +@code{INTEGER} with a value in the range from 1 to n, where n +equals the rank of @var{ARRAY}. +@item @var{MASK} @tab (Optional) shall be of type @code{LOGICAL} +and either be a scalar or an array of the same shape as @var{ARRAY}. +@end multitable + +@item @emph{Return value}: +The result is of the same type as @var{ARRAY}. + +If @var{DIM} is absent, a scalar with the bitwise ALL 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} dropped is returned. + +@item @emph{Example}: +@smallexample +PROGRAM test_iall + INTEGER(1) :: a(2) + + a(1) = b'00100100' + a(1) = b'01101010' + + ! prints 00100000 + PRINT '(b8.8)', IALL(a) +END PROGRAM +@end smallexample + +@item @emph{See also}: +@ref{IANY}, @ref{IPARITY}, @ref{IAND} +@end table + + + @node IAND @section @code{IAND} --- Bitwise logical and @fnindex IAND @@ -5500,6 +5939,66 @@ END PROGRAM +@node IANY +@section @code{IANY} --- Bitwise XOR of array elements +@fnindex IANY +@cindex array, OR +@cindex bits, OR of array elements + +@table @asis +@item @emph{Description}: +Reduces with bitwise OR (inclusive or) the elements of @var{ARRAY} along +dimension @var{DIM} if the corresponding element in @var{MASK} is @code{TRUE}. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Transformational function + +@item @emph{Syntax}: +@multitable @columnfractions .80 +@item @code{RESULT = IANY(ARRAY[, MASK])} +@item @code{RESULT = IANY(ARRAY, DIM[, MASK])} +@end multitable + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER} +@item @var{DIM} @tab (Optional) shall be a scalar of type +@code{INTEGER} with a value in the range from 1 to n, where n +equals the rank of @var{ARRAY}. +@item @var{MASK} @tab (Optional) shall be of type @code{LOGICAL} +and either be a scalar or an array of the same shape as @var{ARRAY}. +@end multitable + +@item @emph{Return value}: +The result is of the same type as @var{ARRAY}. + +If @var{DIM} is absent, a scalar with the bitwise OR 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} dropped is returned. + +@item @emph{Example}: +@smallexample +PROGRAM test_iany + INTEGER(1) :: a(2) + + a(1) = b'00100100' + a(1) = b'01101010' + + ! prints 01111011 + PRINT '(b8.8)', IANY(a) +END PROGRAM +@end smallexample + +@item @emph{See also}: +@ref{IPARITY}, @ref{IALL}, @ref{IOR} +@end table + + + @node IARGC @section @code{IARGC} --- Get the number of command line arguments @fnindex IARGC @@ -5697,6 +6196,12 @@ program test_ichar end program test_ichar @end smallexample +@item @emph{Specific names}: +@multitable @columnfractions .20 .20 .20 .25 +@item Name @tab Argument @tab Return type @tab Standard +@item @code{ICHAR(C)} @tab @code{CHARACTER C} @tab @code{INTEGER(4)} @tab Fortran 77 and later +@end multitable + @item @emph{Note}: No intrinsic exists to convert between a numeric value and a formatted character string representation -- for instance, given the @@ -5843,6 +6348,50 @@ kind. +@node IMAGE_INDEX +@section @code{IMAGE_INDEX} --- Function that converts a cosubscript to an image index +@fnindex IMAGE_INDEX +@cindex coarray, IMAGE_INDEX +@cindex images, cosubscript to image index conversion + +@table @asis +@item @emph{Description}: +Returns the image index belonging to a cosubscript. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Inquiry function. + +@item @emph{Syntax}: +@code{RESULT = IMAGE_INDEX(COARRAY, SUB)} + +@item @emph{Arguments}: None. +@multitable @columnfractions .15 .70 +@item @var{COARRAY} @tab Coarray of any type. +@item @var{SUB} @tab default integer rank-1 array of a size equal to +the corank of @var{COARRAY}. +@end multitable + + +@item @emph{Return value}: +Scalar default integer with the value of the image index which corresponds +to the cosubscripts. For invalid cosubscripts the result is zero. + +@item @emph{Example}: +@smallexample +INTEGER :: array[2,-1:4,8,*] +! Writes 28 (or 0 if there are fewer than 28 images) +WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1]) +@end smallexample + +@item @emph{See also}: +@ref{THIS_IMAGE}, @ref{NUM_IMAGES} +@end table + + + @node INDEX intrinsic @section @code{INDEX} --- Position of a substring within a string @fnindex INDEX @@ -5882,6 +6431,12 @@ expression indicating the kind parameter of the result. The return value is of type @code{INTEGER} and of kind @var{KIND}. If @var{KIND} is absent, the return value is of default integer kind. +@item @emph{Specific names}: +@multitable @columnfractions .20 .20 .20 .25 +@item Name @tab Argument @tab Return type @tab Standard +@item @code{INDEX(STRING, SUBSTRING)} @tab @code{CHARACTER} @tab @code{INTEGER(4)} @tab Fortran 77 and later +@end multitable + @item @emph{See also}: @ref{SCAN}, @ref{VERIFY} @end table @@ -5943,15 +6498,15 @@ end program @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard -@item @code{IFIX(A)} @tab @code{REAL(4) A} @tab @code{INTEGER} @tab Fortran 77 and later -@item @code{IDINT(A)} @tab @code{REAL(8) A} @tab @code{INTEGER} @tab Fortran 77 and later +@item Name @tab Argument @tab Return type @tab Standard +@item @code{INT(A)} @tab @code{REAL(4) A} @tab @code{INTEGER} @tab Fortran 77 and later +@item @code{IFIX(A)} @tab @code{REAL(4) A} @tab @code{INTEGER} @tab Fortran 77 and later +@item @code{IDINT(A)} @tab @code{REAL(8) A} @tab @code{INTEGER} @tab Fortran 77 and later @end multitable @end table - @node INT2 @section @code{INT2} --- Convert to 16-bit integer type @fnindex INT2 @@ -6064,6 +6619,67 @@ the larger argument.) +@node IPARITY +@section @code{IPARITY} --- Bitwise XOR of array elements +@fnindex IPARITY +@cindex array, parity +@cindex array, XOR +@cindex bits, XOR of array elements + +@table @asis +@item @emph{Description}: +Reduces with bitwise XOR (exclusive or) the elements of @var{ARRAY} along +dimension @var{DIM} if the corresponding element in @var{MASK} is @code{TRUE}. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Transformational function + +@item @emph{Syntax}: +@multitable @columnfractions .80 +@item @code{RESULT = IPARITY(ARRAY[, MASK])} +@item @code{RESULT = IPARITY(ARRAY, DIM[, MASK])} +@end multitable + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER} +@item @var{DIM} @tab (Optional) shall be a scalar of type +@code{INTEGER} with a value in the range from 1 to n, where n +equals the rank of @var{ARRAY}. +@item @var{MASK} @tab (Optional) shall be of type @code{LOGICAL} +and either be a scalar or an array of the same shape as @var{ARRAY}. +@end multitable + +@item @emph{Return value}: +The result is of the same type as @var{ARRAY}. + +If @var{DIM} is absent, a scalar with the bitwise XOR 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} dropped is returned. + +@item @emph{Example}: +@smallexample +PROGRAM test_iparity + INTEGER(1) :: a(2) + + a(1) = b'00100100' + a(1) = b'01101010' + + ! prints 10111011 + PRINT '(b8.8)', IPARITY(a) +END PROGRAM +@end smallexample + +@item @emph{See also}: +@ref{IANY}, @ref{IALL}, @ref{IEOR}, @ref{PARITY} +@end table + + + @node IRAND @section @code{IRAND} --- Integer pseudo-random number @fnindex IRAND @@ -6436,7 +7052,10 @@ only one form can be used in any given program unit. Subroutine, function @item @emph{Syntax}: -@code{CALL KILL(C, VALUE [, STATUS])} +@multitable @columnfractions .80 +@item @code{CALL KILL(C, VALUE [, STATUS])} +@item @code{STATUS = KILL(C, VALUE)} +@end multitable @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -6535,7 +7154,46 @@ structure component, or if it has a zero extent along the relevant dimension, the lower bound is taken to be 1. @item @emph{See also}: -@ref{UBOUND} +@ref{UBOUND}, @ref{LCOBOUND} +@end table + + + +@node LCOBOUND +@section @code{LCOBOUND} --- Lower codimension bounds of an array +@fnindex LCOBOUND +@cindex coarray, lower bound + +@table @asis +@item @emph{Description}: +Returns the lower bounds of a coarray, or a single lower cobound +along the @var{DIM} codimension. +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Inquiry function + +@item @emph{Syntax}: +@code{RESULT = LCOBOUND(COARRAY [, DIM [, KIND]])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ARRAY} @tab Shall be an coarray, of any type. +@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER}. +@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization +expression indicating the kind parameter of the result. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{INTEGER} and of kind @var{KIND}. If +@var{KIND} is absent, the return value is of default integer kind. +If @var{DIM} is absent, the result is an array of the lower cobounds of +@var{COARRAY}. If @var{DIM} is present, the result is a scalar +corresponding to the lower cobound of the array along that codimension. + +@item @emph{See also}: +@ref{UCOBOUND}, @ref{LBOUND} @end table @@ -6575,7 +7233,7 @@ END PROGRAM @end smallexample @item @emph{See also}: -@ref{BIT_SIZE}, @ref{TRAILZ} +@ref{BIT_SIZE}, @ref{TRAILZ}, @ref{POPCNT}, @ref{POPPAR} @end table @@ -6613,6 +7271,14 @@ expression indicating the kind parameter of the result. The return value is of type @code{INTEGER} and of kind @var{KIND}. If @var{KIND} is absent, the return value is of default integer kind. + +@item @emph{Specific names}: +@multitable @columnfractions .20 .20 .20 .25 +@item Name @tab Argument @tab Return type @tab Standard +@item @code{LEN(STRING)} @tab @code{CHARACTER} @tab @code{INTEGER} @tab Fortran 77 and later +@end multitable + + @item @emph{See also}: @ref{LEN_TRIM}, @ref{ADJUSTL}, @ref{ADJUSTR} @end table @@ -6695,6 +7361,12 @@ Elemental function Returns @code{.TRUE.} if @code{STRING_A >= STRING_B}, and @code{.FALSE.} otherwise, based on the ASCII ordering. +@item @emph{Specific names}: +@multitable @columnfractions .20 .20 .20 .25 +@item Name @tab Argument @tab Return type @tab Standard +@item @code{LGE(STRING_A, STRING_B)} @tab @code{CHARACTER} @tab @code{LOGICAL} @tab Fortran 77 and later +@end multitable + @item @emph{See also}: @ref{LGT}, @ref{LLE}, @ref{LLT} @end table @@ -6741,6 +7413,12 @@ Elemental function Returns @code{.TRUE.} if @code{STRING_A > STRING_B}, and @code{.FALSE.} otherwise, based on the ASCII ordering. +@item @emph{Specific names}: +@multitable @columnfractions .20 .20 .20 .25 +@item Name @tab Argument @tab Return type @tab Standard +@item @code{LGT(STRING_A, STRING_B)} @tab @code{CHARACTER} @tab @code{LOGICAL} @tab Fortran 77 and later +@end multitable + @item @emph{See also}: @ref{LGE}, @ref{LLE}, @ref{LLT} @end table @@ -6830,6 +7508,12 @@ Elemental function Returns @code{.TRUE.} if @code{STRING_A <= STRING_B}, and @code{.FALSE.} otherwise, based on the ASCII ordering. +@item @emph{Specific names}: +@multitable @columnfractions .20 .20 .20 .25 +@item Name @tab Argument @tab Return type @tab Standard +@item @code{LLE(STRING_A, STRING_B)} @tab @code{CHARACTER} @tab @code{LOGICAL} @tab Fortran 77 and later +@end multitable + @item @emph{See also}: @ref{LGE}, @ref{LGT}, @ref{LLT} @end table @@ -6876,6 +7560,12 @@ Elemental function Returns @code{.TRUE.} if @code{STRING_A < STRING_B}, and @code{.FALSE.} otherwise, based on the ASCII ordering. +@item @emph{Specific names}: +@multitable @columnfractions .20 .20 .20 .25 +@item Name @tab Argument @tab Return type @tab Standard +@item @code{LLT(STRING_A, STRING_B)} @tab @code{CHARACTER} @tab @code{LOGICAL} @tab Fortran 77 and later +@end multitable + @item @emph{See also}: @ref{LGE}, @ref{LGT}, @ref{LLE} @end table @@ -7205,7 +7895,8 @@ Bits shifted out from the left end are lost; zeros are shifted in from the opposite end. This function has been superseded by the @code{ISHFT} intrinsic, which -is standard in Fortran 95 and later. +is standard in Fortran 95 and later, and the @code{SHIFTL} intrinsic, +which is standard in Fortran 2008 and later. @item @emph{Standard}: GNU extension @@ -7227,7 +7918,8 @@ The return value is of type @code{INTEGER} and of the same kind as @var{I}. @item @emph{See also}: -@ref{ISHFT}, @ref{ISHFTC}, @ref{RSHIFT} +@ref{ISHFT}, @ref{ISHFTC}, @ref{RSHIFT}, @ref{SHIFTA}, @ref{SHIFTL}, +@ref{SHIFTR} @end table @@ -7256,7 +7948,10 @@ GNU extension Subroutine, function @item @emph{Syntax}: -@code{CALL LSTAT(NAME, VALUES [, STATUS])} +@multitable @columnfractions .80 +@item @code{CALL LSTAT(NAME, VALUES [, STATUS])} +@item @code{STATUS = LSTAT(NAME, VALUES)} +@end multitable @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -7390,6 +8085,80 @@ end program test_malloc +@node MASKL +@section @code{MASKL} --- Left justified mask +@fnindex MASKL +@cindex mask, left justified + +@table @asis +@item @emph{Description}: +@code{MASKL(I[, KIND])} has its leftmost @var{I} bits set to 1, and the +remaining bits set to 0. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = MASKL(I[, KIND])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{I} @tab Shall be of type @code{INTEGER}. +@item @var{KIND} @tab Shall be a scalar constant expression of type +@code{INTEGER}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{INTEGER}. If @var{KIND} is present, it +specifies the kind value of the return type; otherwise, it is of the +default integer kind. + +@item @emph{See also}: +@ref{MASKR} +@end table + + + +@node MASKR +@section @code{MASKR} --- Right justified mask +@fnindex MASKR +@cindex mask, right justified + +@table @asis +@item @emph{Description}: +@code{MASKL(I[, KIND])} has its rightmost @var{I} bits set to 1, and the +remaining bits set to 0. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = MASKR(I[, KIND])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{I} @tab Shall be of type @code{INTEGER}. +@item @var{KIND} @tab Shall be a scalar constant expression of type +@code{INTEGER}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{INTEGER}. If @var{KIND} is present, it +specifies the kind value of the return type; otherwise, it is of the +default integer kind. + +@item @emph{See also}: +@ref{MASKL} +@end table + + + @node MATMUL @section @code{MATMUL} --- matrix multiplication @fnindex MATMUL @@ -7469,12 +8238,12 @@ and has the same type and kind as the first argument. @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard -@item @code{MAX0(I)} @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)} @tab Fortran 77 and later -@item @code{AMAX0(I)} @tab @code{INTEGER(4) I} @tab @code{REAL(MAX(X))} @tab Fortran 77 and later -@item @code{MAX1(X)} @tab @code{REAL X} @tab @code{INT(MAX(X))} @tab Fortran 77 and later -@item @code{AMAX1(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later -@item @code{DMAX1(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later +@item Name @tab Argument @tab Return type @tab Standard +@item @code{MAX0(A1)} @tab @code{INTEGER(4) A1} @tab @code{INTEGER(4)} @tab Fortran 77 and later +@item @code{AMAX0(A1)} @tab @code{INTEGER(4) A1} @tab @code{REAL(MAX(X))} @tab Fortran 77 and later +@item @code{MAX1(A1)} @tab @code{REAL A1} @tab @code{INT(MAX(X))} @tab Fortran 77 and later +@item @code{AMAX1(A1)} @tab @code{REAL(4) A1} @tab @code{REAL(4)} @tab Fortran 77 and later +@item @code{DMAX1(A1)} @tab @code{REAL(8) A1} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @item @emph{See also}: @@ -7751,6 +8520,43 @@ The result is of the same type and type parameters as @var{TSOURCE}. +@node MERGE_BITS +@section @code{MERGE_BITS} --- Merge of bits under mask +@fnindex MERGE_BITS +@cindex bits, merge + +@table @asis +@item @emph{Description}: +@code{MERGE_BITS(I, J, MASK)} merges the bits of @var{I} and @var{J} +as determined by the mask. The i-th bit of the result is equal to the +i-th bit of @var{I} if the i-th bit of @var{MASK} is 1; it is equal to +the i-th bit of @var{J} otherwise. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = MERGE_BITS(I, J, MASK)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{I} @tab Shall be of type @code{INTEGER}. +@item @var{J} @tab Shall be of type @code{INTEGER} and of the same +kind as @var{I}. +@item @var{MASK} @tab Shall be of type @code{INTEGER} and of the same +kind as @var{I}. +@end multitable + +@item @emph{Return value}: +The result is of the same type and kind as @var{I}. + +@end table + + + @node MIN @section @code{MIN} --- Minimum value of an argument list @fnindex MIN @@ -7789,12 +8595,12 @@ and has the same type and kind as the first argument. @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard -@item @code{MIN0(I)} @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)} @tab Fortran 77 and later -@item @code{AMIN0(I)} @tab @code{INTEGER(4) I} @tab @code{REAL(MIN(X))} @tab Fortran 77 and later -@item @code{MIN1(X)} @tab @code{REAL X} @tab @code{INT(MIN(X))} @tab Fortran 77 and later -@item @code{AMIN1(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 77 and later -@item @code{DMIN1(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 77 and later +@item Name @tab Argument @tab Return type @tab Standard +@item @code{MIN0(A1)} @tab @code{INTEGER(4) A1} @tab @code{INTEGER(4)} @tab Fortran 77 and later +@item @code{AMIN0(A1)} @tab @code{INTEGER(4) A1} @tab @code{REAL(4)} @tab Fortran 77 and later +@item @code{MIN1(A1)} @tab @code{REAL A1} @tab @code{INTEGER(4)} @tab Fortran 77 and later +@item @code{AMIN1(A1)} @tab @code{REAL(4) A1} @tab @code{REAL(4)} @tab Fortran 77 and later +@item @code{DMIN1(A1)} @tab @code{REAL(8) A1} @tab @code{REAL(8)} @tab Fortran 77 and later @end multitable @item @emph{See also}: @@ -8004,9 +8810,10 @@ end program test_mod @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Arguments @tab Return type @tab Standard -@item @code{AMOD(A,P)} @tab @code{REAL(4)} @tab @code{REAL(4)} @tab Fortran 95 and later -@item @code{DMOD(A,P)} @tab @code{REAL(8)} @tab @code{REAL(8)} @tab Fortran 95 and later +@item Name @tab Arguments @tab Return type @tab Standard +@item @code{MOD(A,P)} @tab @code{INTEGER A,P} @tab @code{INTEGER} @tab Fortran 95 and later +@item @code{AMOD(A,P)} @tab @code{REAL(4) A,P} @tab @code{REAL(4)} @tab Fortran 95 and later +@item @code{DMOD(A,P)} @tab @code{REAL(8) A,P} @tab @code{REAL(8)} @tab Fortran 95 and later @end multitable @end table @@ -8283,9 +9090,10 @@ end program test_nint @end smallexample @item @emph{Specific names}: -@multitable @columnfractions .25 .25 .25 -@item Name @tab Argument @tab Standard -@item @code{IDNINT(X)} @tab @code{REAL(8)} @tab Fortran 95 and later +@multitable @columnfractions .20 .20 .20 .25 +@item Name @tab Argument @tab Return Type @tab Standard +@item @code{NINT(A)} @tab @code{REAL(4) A} @tab @code{INTEGER} @tab Fortran 95 and later +@item @code{IDNINT(A)} @tab @code{REAL(8) A} @tab @code{INTEGER} @tab Fortran 95 and later @end multitable @item @emph{See also}: @@ -8295,6 +9103,57 @@ end program test_nint +@node NORM2 +@section @code{NORM2} --- Euclidean vector norms +@fnindex NORM2 +@cindex Euclidean vector norm +@cindex L2 vector norm +@cindex norm, Euclidean + +@table @asis +@item @emph{Description}: +Calculates the Euclidean vector norm (@math{L_2}) norm of +of @var{ARRAY} along dimension @var{DIM}. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Transformational function + +@item @emph{Syntax}: +@multitable @columnfractions .80 +@item @code{RESULT = NORM2(ARRAY[, DIM])} +@end multitable + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ARRAY} @tab Shall be an array of type @code{REAL} +@item @var{DIM} @tab (Optional) shall be a scalar of type +@code{INTEGER} with a value in the range from 1 to n, where n +equals the rank of @var{ARRAY}. +@end multitable + +@item @emph{Return value}: +The result is of the same type as @var{ARRAY}. + +If @var{DIM} is absent, a scalar with the square root of the sum of all +elements in @var{ARRAY} squared is returned. Otherwise, an array of +rank @math{n-1}, where @math{n} equals the rank of @var{ARRAY}, and a +shape similar to that of @var{ARRAY} with dimension @var{DIM} dropped +is returned. + +@item @emph{Example}: +@smallexample +PROGRAM test_sum + REAL :: x(5) = [ real :: 1, 2, 3, 4, 5 ] + print *, NORM2(x) ! = sqrt(55.) ~ 7.416 +END PROGRAM +@end smallexample +@end table + + + @node NOT @section @code{NOT} --- Logical negation @fnindex NOT @@ -8414,7 +9273,7 @@ END IF @end smallexample @item @emph{See also}: -@c FIXME: ref{THIS_IMAGE} +@ref{THIS_IMAGE}, @ref{IMAGE_INDEX} @end table @@ -8541,6 +9400,58 @@ END PROGRAM +@node PARITY +@section @code{PARITY} --- Reduction with exclusive OR +@fnindex PARITY +@cindex Parity +@cindex Reduction, XOR +@cindex XOR reduction + +@table @asis +@item @emph{Description}: +Calculates the partity, i.e. the reduction using @code{.XOR.}, +of @var{MASK} along dimension @var{DIM}. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Transformational function + +@item @emph{Syntax}: +@multitable @columnfractions .80 +@item @code{RESULT = PARITY(MASK[, DIM])} +@end multitable + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{LOGICAL} @tab Shall be an array of type @code{LOGICAL} +@item @var{DIM} @tab (Optional) shall be a scalar of type +@code{INTEGER} with a value in the range from 1 to n, where n +equals the rank of @var{MASK}. +@end multitable + +@item @emph{Return value}: +The result is of the same type as @var{MASK}. + +If @var{DIM} is absent, a scalar with the parity of all elements in +@var{MASK} is returned, i.e. true if an odd number of elements is +@code{.true.} and false otherwise. If @var{DIM} is present, an array +of rank @math{n-1}, where @math{n} equals the rank of @var{ARRAY}, +and a shape similar to that of @var{MASK} with dimension @var{DIM} +dropped is returned. + +@item @emph{Example}: +@smallexample +PROGRAM test_sum + LOGICAL :: x(2) = [ .true., .false. ] + print *, PARITY(x) ! prints "T" (true). +END PROGRAM +@end smallexample +@end table + + + @node PERROR @section @code{PERROR} --- Print system error message @fnindex PERROR @@ -8601,6 +9512,9 @@ Inquiry function The return value is of type @code{INTEGER} and of the default integer kind. +@item @emph{See also}: +@ref{SELECTED_REAL_KIND}, @ref{RANGE} + @item @emph{Example}: @smallexample program prec_and_range @@ -8615,6 +9529,95 @@ end program prec_and_range +@node POPCNT +@section @code{POPCNT} --- Number of bits set +@fnindex POPCNT +@cindex binary representation +@cindex bits set + +@table @asis +@item @emph{Description}: +@code{POPCNT(I)} returns the number of bits set ('1' bits) in the binary +representation of @code{I}. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = POPCNT(I)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{I} @tab Shall be of type @code{INTEGER}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{INTEGER} and of the default integer +kind. + +@item @emph{See also}: +@ref{POPPAR}, @ref{LEADZ}, @ref{TRAILZ} + +@item @emph{Example}: +@smallexample +program test_population + print *, popcnt(127), poppar(127) + print *, popcnt(huge(0_4)), poppar(huge(0_4)) + print *, popcnt(huge(0_8)), poppar(huge(0_8)) +end program test_population +@end smallexample +@end table + + +@node POPPAR +@section @code{POPPAR} --- Parity of the number of bits set +@fnindex POPPAR +@cindex binary representation +@cindex parity + +@table @asis +@item @emph{Description}: +@code{POPPAR(I)} returns parity of the integer @code{I}, i.e. the parity +of the number of bits set ('1' bits) in the binary representation of +@code{I}. It is equal to 0 if @code{I} has an even number of bits set, +and 1 for an odd number of '1' bits. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = POPPAR(I)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{I} @tab Shall be of type @code{INTEGER}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{INTEGER} and of the default integer +kind. + +@item @emph{See also}: +@ref{POPCNT}, @ref{LEADZ}, @ref{TRAILZ} + +@item @emph{Example}: +@smallexample +program test_population + print *, popcnt(127), poppar(127) + print *, popcnt(huge(0_4)), poppar(huge(0_4)) + print *, popcnt(huge(0_8)), poppar(huge(0_8)) +end program test_population +@end smallexample +@end table + + + @node PRESENT @section @code{PRESENT} --- Determine whether an optional dummy argument is specified @fnindex PRESENT @@ -8746,6 +9749,9 @@ Inquiry function The return value is a scalar of type @code{INTEGER} and of the default integer kind. +@item @emph{See also}: +@ref{SELECTED_REAL_KIND} + @item @emph{Example}: @smallexample program test_radix @@ -8983,6 +9989,9 @@ or @code{COMPLEX}. The return value is of type @code{INTEGER} and of the default integer kind. +@item @emph{See also}: +@ref{SELECTED_REAL_KIND}, @ref{PRECISION} + @item @emph{Example}: See @code{PRECISION} for an example. @end table @@ -8993,6 +10002,9 @@ See @code{PRECISION} for an example. @section @code{REAL} --- Convert to real type @fnindex REAL @fnindex REALPART +@fnindex FLOAT +@fnindex DFLOAT +@fnindex SNGL @cindex conversion, to real @cindex complex numbers, real part @@ -9047,8 +10059,17 @@ program test_real end program test_real @end smallexample +@item @emph{Specific names}: +@multitable @columnfractions .20 .20 .20 .25 +@item Name @tab Argument @tab Return type @tab Standard +@item @code{FLOAT(A)} @tab @code{INTEGER(4)} @tab @code{REAL(4)} @tab Fortran 77 and later +@item @code{DFLOAT(A)} @tab @code{INTEGER(4)} @tab @code{REAL(8)} @tab GNU extension +@item @code{SNGL(A)} @tab @code{INTEGER(8)} @tab @code{REAL(4)} @tab Fortran 77 and later +@end multitable + + @item @emph{See also}: -@ref{DBLE}, @ref{DFLOAT}, @ref{FLOAT} +@ref{DBLE} @end table @@ -9236,12 +10257,13 @@ The value returned is equal to @item @emph{Description}: @code{RSHIFT} returns a value corresponding to @var{I} with all of the bits shifted right by @var{SHIFT} places. If the absolute value of -@var{SHIFT} is greater than @code{BIT_SIZE(I)}, the value is undefined. -Bits shifted out from the left end are lost; zeros are shifted in from -the opposite end. +@var{SHIFT} is greater than @code{BIT_SIZE(I)}, the value is undefined. +Bits shifted out from the right end are lost. The fill is arithmetic: the +bits shifted in from the left end are equal to the leftmost bit, which in +two's complement representation is the sign bit. -This function has been superseded by the @code{ISHFT} intrinsic, which -is standard in Fortran 95 and later. +This function has been superseded by the @code{SHIFTA} intrinsic, which +is standard in Fortran 2008 and later. @item @emph{Standard}: GNU extension @@ -9263,7 +10285,44 @@ The return value is of type @code{INTEGER} and of the same kind as @var{I}. @item @emph{See also}: -@ref{ISHFT}, @ref{ISHFTC}, @ref{LSHIFT} +@ref{ISHFT}, @ref{ISHFTC}, @ref{LSHIFT}, @ref{SHIFTA}, @ref{SHIFTR}, +@ref{SHIFTL} + +@end table + + + +@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 @@ -9468,7 +10527,8 @@ seconds. @code{SELECTED_CHAR_KIND(NAME)} returns the kind value for the character set named @var{NAME}, if a character set with such a name is supported, or @math{-1} otherwise. Currently, supported character sets include -``ASCII'' and ``DEFAULT'', which are equivalent. +``ASCII'' and ``DEFAULT'', which are equivalent, and ``ISO_10646'' +(Universal Character Set, UCS-4) which is commonly known as Unicode. @item @emph{Standard}: Fortran 2003 and later @@ -9486,13 +10546,25 @@ Transformational function @item @emph{Example}: @smallexample -program ascii_kind - integer,parameter :: ascii = selected_char_kind("ascii") - character(kind=ascii, len=26) :: s +program character_kind + use iso_fortran_env + implicit none + integer, parameter :: ascii = selected_char_kind ("ascii") + integer, parameter :: ucs4 = selected_char_kind ('ISO_10646') + + character(kind=ascii, len=26) :: alphabet + character(kind=ucs4, len=30) :: hello_world - s = ascii_"abcdefghijklmnopqrstuvwxyz" - print *, s -end program ascii_kind + alphabet = ascii_"abcdefghijklmnopqrstuvwxyz" + hello_world = ucs4_'Hello World and Ni Hao -- ' & + // char (int (z'4F60'), ucs4) & + // char (int (z'597D'), ucs4) + + write (*,*) alphabet + + open (output_unit, encoding='UTF-8') + write (*,*) trim (hello_world) +end program character_kind @end smallexample @end table @@ -9549,45 +10621,58 @@ end program large_integers @fnindex SELECTED_REAL_KIND @cindex real kind @cindex kind, real +@cindex radix, real @table @asis @item @emph{Description}: @code{SELECTED_REAL_KIND(P,R)} returns the kind value of a real data type -with decimal precision of at least @code{P} digits and exponent -range greater at least @code{R}. +with decimal precision of at least @code{P} digits, exponent range of +at least @code{R}, and with a radix of @code{RADIX}. @item @emph{Standard}: -Fortran 95 and later +Fortran 95 and later, with @code{RADIX} Fortran 2008 or later @item @emph{Class}: Transformational function @item @emph{Syntax}: -@code{RESULT = SELECTED_REAL_KIND([P, R])} +@code{RESULT = SELECTED_REAL_KIND([P, R, RADIX])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{P} @tab (Optional) shall be a scalar and of type @code{INTEGER}. @item @var{R} @tab (Optional) shall be a scalar and of type @code{INTEGER}. +@item @var{RADIX} @tab (Optional) shall be a scalar and of type @code{INTEGER}. @end multitable -At least one argument shall be present. +Before Fortran 2008, at least one of the arguments @var{R} or @var{P} shall +be present; since Fortran 2008, they are assumed to be zero if absent. @item @emph{Return value}: @code{SELECTED_REAL_KIND} returns the value of the kind type parameter of -a real data type with decimal precision of at least @code{P} digits and a -decimal exponent range of at least @code{R}. If more than one real data -type meet the criteria, the kind of the data type with the smallest -decimal precision is returned. If no real data type matches the criteria, -the result is +a real data type with decimal precision of at least @code{P} digits, a +decimal exponent range of at least @code{R}, and with the requested +@code{RADIX}. If the @code{RADIX} parameter is absent, real kinds with +any radix can be returned. If more than one real data type meet the +criteria, the kind of the data type with the smallest decimal precision +is returned. If no real data type matches the criteria, the result is @table @asis @item -1 if the processor does not support a real data type with a -precision greater than or equal to @code{P} +precision greater than or equal to @code{P}, but the @code{R} and +@code{RADIX} requirements can be fulfilled @item -2 if the processor does not support a real type with an exponent -range greater than or equal to @code{R} -@item -3 if neither is supported. +range greater than or equal to @code{R}, but @code{P} and @code{RADIX} +are fulfillable +@item -3 if @code{RADIX} but not @code{P} and @code{R} requirements +are fulfillable +@item -4 if @code{RADIX} and either @code{P} or @code{R} requirements +are fulfillable +@item -5 if there is no real type with the given @code{RADIX} @end table +@item @emph{See also}: +@ref{PRECISION}, @ref{RANGE}, @ref{RADIX} + @item @emph{Example}: @smallexample program real_kinds @@ -9698,6 +10783,124 @@ END PROGRAM +@node SHIFTA +@section @code{SHIFTA} --- Right shift with fill +@fnindex SHIFTA +@cindex bits, shift right +@cindex shift, right with fill + +@table @asis +@item @emph{Description}: +@code{SHIFTA} returns a value corresponding to @var{I} with all of the +bits shifted right by @var{SHIFT} places. If the absolute value of +@var{SHIFT} is greater than @code{BIT_SIZE(I)}, the value is undefined. +Bits shifted out from the right end are lost. The fill is arithmetic: the +bits shifted in from the left end are equal to the leftmost bit, which in +two's complement representation is the sign bit. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = SHIFTA(I, SHIFT)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{I} @tab The type shall be @code{INTEGER}. +@item @var{SHIFT} @tab The type shall be @code{INTEGER}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{INTEGER} and of the same kind as +@var{I}. + +@item @emph{See also}: +@ref{SHIFTL}, @ref{SHIFTR} +@end table + + + +@node SHIFTL +@section @code{SHIFTL} --- Left shift +@fnindex SHIFTL +@cindex bits, shift left +@cindex shift, left + +@table @asis +@item @emph{Description}: +@code{SHIFTL} returns a value corresponding to @var{I} with all of the +bits shifted left by @var{SHIFT} places. If the absolute value of +@var{SHIFT} is greater than @code{BIT_SIZE(I)}, the value is undefined. +Bits shifted out from the left end are lost, and bits shifted in from +the right end are set to 0. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = SHIFTL(I, SHIFT)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{I} @tab The type shall be @code{INTEGER}. +@item @var{SHIFT} @tab The type shall be @code{INTEGER}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{INTEGER} and of the same kind as +@var{I}. + +@item @emph{See also}: +@ref{SHIFTA}, @ref{SHIFTR} +@end table + + + +@node SHIFTR +@section @code{SHIFTR} --- Right shift +@fnindex SHIFTR +@cindex bits, shift right +@cindex shift, right + +@table @asis +@item @emph{Description}: +@code{SHIFTR} returns a value corresponding to @var{I} with all of the +bits shifted right by @var{SHIFT} places. If the absolute value of +@var{SHIFT} is greater than @code{BIT_SIZE(I)}, the value is undefined. +Bits shifted out from the right end are lost, and bits shifted in from +the left end are set to 0. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = SHIFTR(I, SHIFT)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{I} @tab The type shall be @code{INTEGER}. +@item @var{SHIFT} @tab The type shall be @code{INTEGER}. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{INTEGER} and of the same kind as +@var{I}. + +@item @emph{See also}: +@ref{SHIFTA}, @ref{SHIFTL} +@end table + + + @node SIGN @section @code{SIGN} --- Sign copying function @fnindex SIGN @@ -9744,9 +10947,10 @@ end program test_sign @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Arguments @tab Return type @tab Standard -@item @code{ISIGN(A,P)} @tab @code{INTEGER(4)} @tab @code{INTEGER(4)} @tab f95, gnu -@item @code{DSIGN(A,P)} @tab @code{REAL(8)} @tab @code{REAL(8)} @tab f95, gnu +@item Name @tab Arguments @tab Return type @tab Standard +@item @code{SIGN(A,B)} @tab @code{REAL(4) A, B} @tab @code{REAL(4)} @tab f77, gnu +@item @code{ISIGN(A,B)} @tab @code{INTEGER(4) A, B} @tab @code{INTEGER(4)} @tab f77, gnu +@item @code{DSIGN(A,B)} @tab @code{REAL(8) A, B} @tab @code{REAL(8)} @tab f77, gnu @end multitable @end table @@ -9852,11 +11056,12 @@ end program test_sin @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard -@item @code{DSIN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu -@item @code{CSIN(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab f95, gnu -@item @code{ZSIN(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab f95, gnu -@item @code{CDSIN(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab f95, gnu +@item Name @tab Argument @tab Return type @tab Standard +@item @code{SIN(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab f77, gnu +@item @code{DSIN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu +@item @code{CSIN(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab f95, gnu +@item @code{ZSIN(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab f95, gnu +@item @code{CDSIN(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab f95, gnu @end multitable @item @emph{See also}: @@ -9905,6 +11110,7 @@ end program test_sinh @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard +@item @code{SINH(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 95 and later @item @code{DSINH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 95 and later @end multitable @@ -9994,7 +11200,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 @@ -10007,7 +11214,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 @@ -10044,40 +11251,6 @@ end -@node SNGL -@section @code{SNGL} --- Convert double precision real to default real -@fnindex SNGL -@cindex conversion, to real - -@table @asis -@item @emph{Description}: -@code{SNGL(A)} converts the double precision real @var{A} -to a default real value. This is an archaic form of @code{REAL} -that is specific to one type for @var{A}. - -@item @emph{Standard}: -Fortran 77 and later - -@item @emph{Class}: -Elemental function - -@item @emph{Syntax}: -@code{RESULT = SNGL(A)} - -@item @emph{Arguments}: -@multitable @columnfractions .15 .70 -@item @var{A} @tab The type shall be a double precision @code{REAL}. -@end multitable - -@item @emph{Return value}: -The return value is of type default @code{REAL}. - -@item @emph{See also}: -@ref{DBLE} -@end table - - - @node SPACING @section @code{SPACING} --- Smallest distance between two numbers of a given type @fnindex SPACING @@ -10218,6 +11391,7 @@ end program test_sqrt @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard +@item @code{SQRT(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 95 and later @item @code{DSQRT(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 95 and later @item @code{CSQRT(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab Fortran 95 and later @item @code{ZSQRT(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab GNU extension @@ -10316,7 +11490,10 @@ GNU extension Subroutine, function @item @emph{Syntax}: -@code{CALL STAT(NAME, VALUES [, STATUS])} +@multitable @columnfractions .80 +@item @code{CALL STAT(NAME, VALUES [, STATUS])} +@item @code{STATUS = STAT(NAME, VALUES)} +@end multitable @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -10359,6 +11536,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 @@ -10400,7 +11608,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}: @@ -10498,6 +11706,8 @@ Subroutine, function @end multitable @item @emph{See also}: +@ref{EXECUTE_COMMAND_LINE}, which is part of the Fortran 2008 standard +and should considered in new code for future portability. @end table @@ -10529,7 +11739,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)}. @@ -10592,8 +11801,9 @@ end program test_tan @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 -@item Name @tab Argument @tab Return type @tab Standard -@item @code{DTAN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 95 and later +@item Name @tab Argument @tab Return type @tab Standard +@item @code{TAN(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 95 and later +@item @code{DTAN(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 95 and later @end multitable @item @emph{See also}: @@ -10645,6 +11855,7 @@ end program test_tanh @item @emph{Specific names}: @multitable @columnfractions .20 .20 .20 .25 @item Name @tab Argument @tab Return type @tab Standard +@item @code{TANH(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 95 and later @item @code{DTANH(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab Fortran 95 and later @end multitable @@ -10654,6 +11865,64 @@ end program test_tanh +@node THIS_IMAGE +@section @code{THIS_IMAGE} --- Function that returns the cosubscript index of this image +@fnindex THIS_IMAGE +@cindex coarray, THIS_IMAGE +@cindex images, index of this image + +@table @asis +@item @emph{Description}: +Returns the cosubscript for this image. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Transformational function + +@item @emph{Syntax}: +@multitable @columnfractions .80 +@item @code{RESULT = THIS_IMAGE()} +@item @code{RESULT = THIS_IMAGE(COARRAY [, DIM])} +@end multitable + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{COARRAY} @tab Coarray of any type (optional; if @var{DIM} +present, required). +@item @var{DIM} @tab default integer scalar (optional). If present, +@var{DIM} shall be between one and the corank of @var{COARRAY}. +@end multitable + + +@item @emph{Return value}: +Default integer. If @var{COARRAY} is not present, it is scalar and its value +is the index of the invoking image. Otherwise, if @var{DIM} is not present, +a rank-1 array with corank elements is returned, containing the cosubscripts +for @var{COARRAY} specifying the invoking image. If @var{DIM} is present, +a scalar is returned, with the value of the @var{DIM} element of +@code{THIS_IMAGE(COARRAY)}. + +@item @emph{Example}: +@smallexample +INTEGER :: value[*] +INTEGER :: i +value = THIS_IMAGE() +SYNC ALL +IF (THIS_IMAGE() == 1) THEN + DO i = 1, NUM_IMAGES() + WRITE(*,'(2(a,i0))') 'value[', i, '] is ', value[i] + END DO +END IF +@end smallexample + +@item @emph{See also}: +@ref{NUM_IMAGES}, @ref{IMAGE_INDEX} +@end table + + + @node TIME @section @code{TIME} --- Time function @fnindex TIME @@ -10803,7 +12072,7 @@ END PROGRAM @end smallexample @item @emph{See also}: -@ref{BIT_SIZE}, @ref{LEADZ} +@ref{BIT_SIZE}, @ref{LEADZ}, @ref{POPPAR}, @ref{POPCNT} @end table @@ -11030,7 +12299,46 @@ dimension, the upper bound is taken to be the number of elements along the relevant dimension. @item @emph{See also}: -@ref{LBOUND} +@ref{LBOUND}, @ref{LCOBOUND} +@end table + + + +@node UCOBOUND +@section @code{UCOBOUND} --- Upper codimension bounds of an array +@fnindex UCOBOUND +@cindex coarray, upper bound + +@table @asis +@item @emph{Description}: +Returns the upper cobounds of a coarray, or a single upper cobound +along the @var{DIM} codimension. +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Inquiry function + +@item @emph{Syntax}: +@code{RESULT = UCOBOUND(COARRAY [, DIM [, KIND]])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ARRAY} @tab Shall be an coarray, of any type. +@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER}. +@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization +expression indicating the kind parameter of the result. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{INTEGER} and of kind @var{KIND}. If +@var{KIND} is absent, the return value is of default integer kind. +If @var{DIM} is absent, the result is an array of the lower cobounds of +@var{COARRAY}. If @var{DIM} is present, the result is a scalar +corresponding to the lower cobound of the array along that codimension. + +@item @emph{See also}: +@ref{LCOBOUND}, @ref{LBOUND} @end table @@ -11053,8 +12361,10 @@ GNU extension Subroutine, function @item @emph{Syntax}: -@code{CALL UMASK(MASK [, OLD])} -@code{OLD = UMASK(MASK)} +@multitable @columnfractions .80 +@item @code{CALL UMASK(MASK [, OLD])} +@item @code{OLD = UMASK(MASK)} +@end multitable @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -11281,14 +12591,21 @@ Fortran 95 elemental function: @ref{IEOR} @section @code{ISO_FORTRAN_ENV} @table @asis @item @emph{Standard}: -Fortran 2003 and later; @code{INT8}, @code{INT16}, @code{INT32}, @code{INT64}, -@code{REAL32}, @code{REAL64}, @code{REAL128} are Fortran 2008 or later +Fortran 2003 and later, except when otherwise noted @end table The @code{ISO_FORTRAN_ENV} module provides the following scalar default-integer named constants: @table @asis +@item @code{ATOMIC_INT_KIND}: +Default-kind integer constant to be used as kind parameter when defining +integer variables used in atomic operations. (Fortran 2008 or later.) + +@item @code{ATOMIC_LOGICAL_KIND}: +Default-kind integer constant to be used as kind parameter when defining +logical variables used in atomic operations. (Fortran 2008 or later.) + @item @code{CHARACTER_STORAGE_SIZE}: Size in bits of the character storage unit. @@ -11302,10 +12619,10 @@ Size in bits of the file-storage unit. Identifies the preconnected unit identified by the asterisk (@code{*}) in @code{READ} statement. -@item @code{INT8}, @code{INT16}, @code{INT32}, @code{INT64} +@item @code{INT8}, @code{INT16}, @code{INT32}, @code{INT64}: Kind type parameters to specify an INTEGER type with a storage size of 16, 32, and 64 bits. It is negative if a target platform -does not support the particular kind. +does not support the particular kind. (Fortran 2008 or later.) @item @code{IOSTAT_END}: The value assigned to the variable passed to the IOSTAT= specifier of @@ -11315,6 +12632,11 @@ an input/output statement if an end-of-file condition occurred. The value assigned to the variable passed to the IOSTAT= specifier of an input/output statement if an end-of-record condition occurred. +@item @code{IOSTAT_INQUIRE_INTERNAL_UNIT}: +Scalar default-integer constant, used by @code{INQUIRE} for the +IOSTAT= specifier to denote an that a unit number identifies an +internal unit. (Fortran 2008 or later.) + @item @code{NUMERIC_STORAGE_SIZE}: The size in bits of the numeric storage unit. @@ -11322,10 +12644,29 @@ The size in bits of the numeric storage unit. Identifies the preconnected unit identified by the asterisk (@code{*}) in @code{WRITE} statement. -@item @code{REAL32}, @code{REAL64}, @code{REAL128} +@item @code{REAL32}, @code{REAL64}, @code{REAL128}: Kind type parameters to specify a REAL type with a storage size of 32, 64, and 128 bits. It is negative if a target platform -does not support the particular kind. +does not support the particular kind. (Fortran 2008 or later.) + +@item @code{STAT_LOCKED}: +Scalar default-integer constant used as STAT= return value by @code{LOCK} to +denote that the lock variable is locked by the executing image. (Fortran 2008 +or later.) + +@item @code{STAT_LOCKED_OTHER_IMAGE}: +Scalar default-integer constant used as STAT= return value by @code{UNLOCK} to +denote that the lock variable is locked by another image. (Fortran 2008 or +later.) + +@item @code{STAT_STOPPED_IMAGE}: +Positive, scalar default-integer constant used as STAT= return value if the +argument in the statement requires synchronisation with an image, which has +initiated the termination of the execution. (Fortran 2008 or later.) + +@item @code{STAT_UNLOCKED}: +Scalar default-integer constant used as STAT= return value by @code{UNLOCK} to +denote that the lock variable is unlocked. (Fortran 2008 or later.) @end table @@ -11409,6 +12750,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/invoke.texi b/gcc/fortran/invoke.texi index 6d3681d69a1..1dfd3bdd920 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -5,11 +5,11 @@ @ignore @c man begin COPYRIGHT -Copyright @copyright{} 2004, 2005, 2006, 2007, 2008, 2009 +Copyright @copyright{} 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Permission is granted to copy, distribute and/or modify this document -under the terms of the GNU Free Documentation License, Version 1.2 or +under the terms of the GNU Free Documentation License, Version 1.3 or any later version published by the Free Software Foundation; with the Invariant Sections being ``Funding Free Software'', the Front-Cover Texts being (a) (see below), and with the Back-Cover Texts being (b) @@ -148,8 +148,7 @@ and warnings}. @item Directory Options @xref{Directory Options,,Options for directory search}. -@gccoptlist{-I@var{dir} -J@var{dir} -M@var{dir} @gol --fintrinsic-modules-path @var{dir}} +@gccoptlist{-I@var{dir} -J@var{dir} -fintrinsic-modules-path @var{dir}} @item Link Options @xref{Link Options,,Options for influencing the linking step}. @@ -166,8 +165,8 @@ and warnings}. @gccoptlist{-fno-automatic -ff2c -fno-underscoring @gol -fwhole-file -fsecond-underscore @gol -fbounds-check -fcheck-array-temporaries -fmax-array-constructor =@var{n} @gol --fcheck=@var{<all|array-temps|bounds|do|mem|pointer|recursion>} --fmax-stack-var-size=@var{n} @gol +-fcheck=@var{<all|array-temps|bounds|do|mem|pointer|recursion>} @gol +-fcoarray=@var{<none|single>} -fmax-stack-var-size=@var{n} @gol -fpack-derived -frepack-arrays -fshort-enums -fexternal-blas @gol -fblas-matmul-limit=@var{n} -frecursive -finit-local-zero @gol -finit-integer=@var{n} -finit-real=@var{<zero|inf|-inf|nan|snan>} @gol @@ -688,9 +687,10 @@ warnings. @cindex warnings, all Enables commonly used warning options pertaining to usage that we recommend avoiding and that we believe are easy to avoid. -This currently includes @option{-Waliasing}, -@option{-Wampersand}, @option{-Wsurprising}, @option{-Wintrinsics-std}, -@option{-Wno-tabs}, @option{-Wintrinsic-shadow} and @option{-Wline-truncation}. +This currently includes @option{-Waliasing}, @option{-Wampersand}, +@option{-Wconversion}, @option{-Wsurprising}, @option{-Wintrinsics-std}, +@option{-Wno-tabs}, @option{-Wintrinsic-shadow}, @option{-Wline-truncation}, +and @option{-Wunused}. @item -Waliasing @opindex @code{Waliasing} @@ -746,7 +746,14 @@ Warn when a source code line will be truncated. @opindex @code{Wconversion} @cindex warnings, conversion @cindex conversion -Warn about implicit conversions between different types. +Warn about implicit conversions that are likely to change the value of +the expression after conversion. Implied by @option{-Wall}. + +@item -Wconversion-extra +@opindex @code{Wconversion-extra} +@cindex warnings, conversion +@cindex conversion +Warn about implicit conversions between different types and kinds. @item -Wimplicit-interface @opindex @code{Wimplicit-interface} @@ -825,15 +832,22 @@ intrinsic; in this case, an explicit interface or @code{EXTERNAL} or @code{INTRINSIC} declaration might be needed to get calls later resolved to the desired intrinsic/procedure. +@item -Wunused-dummy-argument +@opindex @code{Wunused-dummy-argument} +@cindex warnings, unused dummy argument +@cindex unused dummy argument +@cindex dummy argument, unused +Warn about unused dummy arguments. This option is implied by @option{-Wall}. + @item -Wunused-parameter @opindex @code{Wunused-parameter} @cindex warnings, unused parameter @cindex unused parameter Contrary to @command{gcc}'s meaning of @option{-Wunused-parameter}, @command{gfortran}'s implementation of this option does not warn -about unused dummy arguments, but about unused @code{PARAMETER} values. -@option{-Wunused-parameter} is not included in @option{-Wall} but is -implied by @option{-Wall -Wextra}. +about unused dummy arguments (see @option{-Wunused-dummy-argument}), +but about unused @code{PARAMETER} values. @option{-Wunused-parameter} +is not included in @option{-Wall} but is implied by @option{-Wall -Wextra}. @item -Walign-commons @opindex @code{Walign-commons} @@ -949,7 +963,6 @@ gcc,Using the GNU Compiler Collection (GCC)}, for information on the @option{-I} option. @item -J@var{dir} -@item -M@var{dir} @opindex @code{J}@var{dir} @opindex @code{M}@var{dir} @cindex paths, search @@ -960,8 +973,6 @@ statement. The default is the current directory. -@option{-M} is deprecated to avoid conflicts with existing GCC options. - @item -fintrinsic-modules-path @var{dir} @opindex @code{fintrinsic-modules-path} @var{dir} @cindex paths, search @@ -1212,6 +1223,20 @@ is implemented as a reference to the link-time external symbol for compatibility with @command{g77} and @command{f2c}, and is implied by use of the @option{-ff2c} option. +@item -fcoarray=@var{<keyword>} +@opindex @code{fcoarray} +@cindex coarrays + +@table @asis +@item @samp{none} +Disable coarray support; using coarray declarations and image-control +statements will produce a compile-time error. (Default) + +@item @samp{single} +Single-image mode, i.e. @code{num_images()} is always one. +@end table + + @item -fcheck=@var{<keyword>} @opindex @code{fcheck} @cindex array, bounds checking diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 9b0ee8d17ca..afbde0210b4 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -1,5 +1,6 @@ /* Deal with I/O statements & related stuff. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, + 2009, 2010 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -729,7 +730,7 @@ data_desc: t = format_lex (); if (t == FMT_ERROR) goto fail; - if (gfc_option.allow_std < GFC_STD_F2003 && t != FMT_COMMA + if (!(gfc_option.allow_std & GFC_STD_F2003) && t != FMT_COMMA && t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES && t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH) { @@ -850,11 +851,11 @@ data_desc: if (u != FMT_POSINT) { format_locus.nextc += format_string_pos; - gfc_error_now ("Positive width required in format " + gfc_error ("Positive width required in format " "specifier %s at %L", token_to_string (t), &format_locus); saved_token = u; - goto finished; + goto fail; } u = format_lex (); @@ -866,11 +867,11 @@ data_desc: format_locus.nextc += format_string_pos; if (gfc_option.warn_std != 0) { - gfc_error_now ("Period required in format " + gfc_error ("Period required in format " "specifier %s at %L", token_to_string (t), &format_locus); saved_token = u; - goto finished; + goto fail; } else gfc_warning ("Period required in format " @@ -970,11 +971,11 @@ data_desc: gfc_warning ("The H format specifier at %L is" " a Fortran 95 deleted feature", &format_locus); } - if (mode == MODE_STRING) { format_string += value; format_length -= value; + format_string_pos += repeat; } else { @@ -1152,6 +1153,8 @@ finished: static gfc_try check_format_string (gfc_expr *e, bool is_input) { + gfc_try rv; + int i; if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) return SUCCESS; @@ -1162,8 +1165,20 @@ check_format_string (gfc_expr *e, bool is_input) format string that has been calculated, but that's probably not worth the effort. */ format_locus = e->where; - - return check_format (is_input); + rv = check_format (is_input); + /* check for extraneous characters at the end of an otherwise valid format + string, like '(A10,I3)F5' + start at the end and move back to the last character processed, + spaces are OK */ + if (rv == SUCCESS && e->value.character.length > format_string_pos) + for (i=e->value.character.length-1;i>format_string_pos-1;i--) + if (e->value.character.string[i] != ' ') + { + format_locus.nextc += format_length + 1; + gfc_warning ("Extraneous characters in format at %L", &format_locus); + break; + } + return rv; } @@ -1215,14 +1230,9 @@ gfc_match_format (void) new_st.loc = start; new_st.op = EXEC_NOP; - e = gfc_get_expr(); - e->expr_type = EXPR_CONSTANT; - e->ts.type = BT_CHARACTER; - e->ts.kind = gfc_default_character_kind; - e->where = start; - e->value.character.string = format_string - = gfc_get_wide_string (format_length + 1); - e->value.character.length = format_length; + e = gfc_get_character_expr (gfc_default_character_kind, &start, + NULL, format_length); + format_string = e->value.character.string; gfc_statement_label->format = e; mode = MODE_COPY; @@ -1487,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", @@ -1761,8 +1779,6 @@ gfc_match_open (void) if (m == MATCH_NO) { m = gfc_match_expr (&open->unit); - if (m == MATCH_NO) - goto syntax; if (m == MATCH_ERROR) goto cleanup; } @@ -1810,6 +1826,11 @@ gfc_match_open (void) goto cleanup; } } + else if (!open->unit) + { + gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified"); + goto cleanup; + } /* Checks on the ACCESS specifier. */ if (open->access && open->access->expr_type == EXPR_CONSTANT) @@ -2425,7 +2446,7 @@ default_unit (io_kind k) else unit = 6; - return gfc_int_expr (unit); + return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit); } @@ -3641,17 +3662,8 @@ get_io_list: that might have a format expression without unit number. */ if (!comma_flag && gfc_match_char (',') == MATCH_YES) { - dt->extra_comma = gfc_get_expr (); - - /* Set the types to something compatible with iokind. This is needed to - get through gfc_free_expr later since iokind really has no Basic Type, - BT, of its own. */ - dt->extra_comma->expr_type = EXPR_CONSTANT; - dt->extra_comma->ts.type = BT_LOGICAL; - /* Save the iokind and locus for later use in resolution. */ - dt->extra_comma->value.iokind = k; - dt->extra_comma->where = gfc_current_locus; + dt->extra_comma = gfc_get_iokind_expr (&gfc_current_locus, k); } io_code = NULL; diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index a2ed88ca748..e7a92da905e 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -34,6 +34,7 @@ along with GCC; see the file COPYING3. If not see #include "tree.h" #include "gfortran.h" #include "intrinsic.h" +#include "constructor.h" /* Given printf-like arguments, return a stable version of the result string. @@ -68,12 +69,18 @@ check_charlen_present (gfc_expr *source) if (source->expr_type == EXPR_CONSTANT) { - source->ts.u.cl->length = gfc_int_expr (source->value.character.length); + source->ts.u.cl->length + = gfc_get_int_expr (gfc_default_integer_kind, NULL, + source->value.character.length); source->rank = 0; } else if (source->expr_type == EXPR_ARRAY) - source->ts.u.cl->length = - gfc_int_expr (source->value.constructor->expr->value.character.length); + { + gfc_constructor *c = gfc_constructor_first (source->value.constructor); + source->ts.u.cl->length + = gfc_get_int_expr (gfc_default_integer_kind, NULL, + c->expr->value.character.length); + } } /* Helper function for resolving the "mask" argument. */ @@ -112,6 +119,62 @@ 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, bool coarray) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + + if (dim == NULL) + { + f->rank = 1; + f->shape = gfc_get_shape (1); + mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array) + : array->rank); + } + + f->value.function.name = xstrdup (name); +} + + +static void +resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array, + gfc_expr *dim, gfc_expr *mask) +{ + const char *prefix; + + f->ts = array->ts; + + if (mask) + { + if (mask->rank == 0) + prefix = "s"; + else + prefix = "m"; + + resolve_mask_arg (mask); + } + else + prefix = ""; + + if (dim != NULL) + { + f->rank = array->rank - 1; + f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim); + gfc_resolve_dim_arg (dim); + } + + f->value.function.name + = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name, + gfc_type_letter (array->ts.type), array->ts.kind); +} + + /********************** Resolution functions **********************/ @@ -163,7 +226,7 @@ gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind, f->ts.kind = (kind == NULL) ? gfc_default_character_kind : mpz_get_si (kind->value.integer); f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - f->ts.u.cl->length = gfc_int_expr (1); + f->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); f->value.function.name = gfc_get_string (name, f->ts.kind, gfc_type_letter (x->ts.type), @@ -387,6 +450,45 @@ gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x) void +gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts = x->ts; + f->rank = 1; + if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT) + { + f->shape = gfc_get_shape (1); + mpz_init (f->shape[0]); + mpz_sub (f->shape[0], n2->value.integer, n1->value.integer); + mpz_add_ui (f->shape[0], f->shape[0], 1); + } + + if (n1->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + gfc_convert_type (n1, &ts, 2); + } + + if (n2->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + gfc_convert_type (n2, &ts, 2); + } + + if (f->value.function.isym->id == GFC_ISYM_JN2) + f->value.function.name = gfc_get_string (PREFIX ("bessel_jn_r%d"), + f->ts.kind); + else + f->value.function.name = gfc_get_string (PREFIX ("bessel_yn_r%d"), + f->ts.kind); +} + + +void gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos) { f->ts.type = BT_LOGICAL; @@ -488,7 +590,8 @@ gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind) void gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y) { - gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind)); + gfc_resolve_cmplx (f, x, y, gfc_get_int_expr (gfc_default_integer_kind, NULL, + gfc_default_double_kind)); } @@ -722,6 +825,20 @@ gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED, void +gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED, + gfc_expr *shift ATTRIBUTE_UNUSED) +{ + f->ts = i->ts; + if (f->value.function.isym->id == GFC_ISYM_DSHIFTL) + f->value.function.name = gfc_get_string ("dshiftl_i%d", f->ts.kind); + else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR) + f->value.function.name = gfc_get_string ("dshiftr_i%d", f->ts.kind); + else + gcc_unreachable (); +} + + +void gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, gfc_expr *dim) { @@ -853,6 +970,10 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo) f->ts.type = BT_LOGICAL; f->ts.kind = 4; + + f->value.function.isym->formal->ts = a->ts; + f->value.function.isym->formal->next->ts = mo->ts; + /* Call library function. */ f->value.function.name = gfc_get_string (PREFIX ("is_extension_of")); } @@ -971,6 +1092,13 @@ gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED) void +gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + resolve_transformational ("iall", f, array, dim, mask); +} + + +void gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j) { /* If the kind of i and j are different, then g77 cross-promoted the @@ -990,6 +1118,13 @@ gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j) void +gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + resolve_transformational ("iany", f, array, dim, mask); +} + + +void gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED) { f->ts = i->ts; @@ -1166,6 +1301,13 @@ gfc_resolve_long (gfc_expr *f, gfc_expr *a) void +gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + resolve_transformational ("iparity", f, array, dim, mask); +} + + +void gfc_resolve_isatty (gfc_expr *f, gfc_expr *u) { gfc_typespec ts; @@ -1239,22 +1381,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) { - static char lbound[] = "__lbound"; - - f->ts.type = BT_INTEGER; - if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = gfc_default_integer_kind; + resolve_bound (f, array, dim, kind, "__lbound", false); +} - if (dim == NULL) - { - f->rank = 1; - f->shape = gfc_get_shape (1); - mpz_init_set_ui (f->shape[0], array->rank); - } - f->value.function.name = lbound; +void +gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + resolve_bound (f, array, dim, kind, "__lcobound", true); } @@ -1569,6 +1703,21 @@ gfc_resolve_mclock8 (gfc_expr *f) void +gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED, + gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = kind ? mpz_get_si (kind->value.integer) + : gfc_default_integer_kind; + + if (f->value.function.isym->id == GFC_ISYM_MASKL) + f->value.function.name = gfc_get_string ("__maskl_i%d", f->ts.kind); + else + f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind); +} + + +void gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource, gfc_expr *fsource ATTRIBUTE_UNUSED, gfc_expr *mask ATTRIBUTE_UNUSED) @@ -1590,6 +1739,16 @@ gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource, void +gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i, + gfc_expr *j ATTRIBUTE_UNUSED, + gfc_expr *mask ATTRIBUTE_UNUSED) +{ + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__merge_bits_i%d", i->ts.kind); +} + + +void gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args) { gfc_resolve_minmax ("__min_%c%d", f, args); @@ -1760,6 +1919,13 @@ gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind) void +gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim) +{ + resolve_transformational ("norm2", f, array, dim, NULL); +} + + +void gfc_resolve_not (gfc_expr *f, gfc_expr *i) { f->ts = i->ts; @@ -1824,35 +1990,17 @@ gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask, void -gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim, - gfc_expr *mask) +gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim) { - const char *name; - - f->ts = array->ts; - - if (dim != NULL) - { - f->rank = array->rank - 1; - f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim); - gfc_resolve_dim_arg (dim); - } - - if (mask) - { - if (mask->rank == 0) - name = "sproduct"; - else - name = "mproduct"; + resolve_transformational ("parity", f, array, dim, NULL); +} - resolve_mask_arg (mask); - } - else - name = "product"; - f->value.function.name - = gfc_get_string (PREFIX ("%s_%c%d"), name, - gfc_type_letter (array->ts.type), array->ts.kind); +void +gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim, + gfc_expr *mask) +{ + resolve_transformational ("product", f, array, dim, mask); } @@ -1968,11 +2116,11 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape, { gfc_constructor *c; f->shape = gfc_get_shape (f->rank); - c = shape->value.constructor; + c = gfc_constructor_first (shape->value.constructor); for (i = 0; i < f->rank; i++) { mpz_init_set (f->shape[i], c->expr->value.integer); - c = c->next; + c = gfc_constructor_next (c); } } @@ -2049,6 +2197,21 @@ gfc_resolve_shape (gfc_expr *f, gfc_expr *array) void +gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED) +{ + f->ts = i->ts; + if (f->value.function.isym->id == GFC_ISYM_SHIFTA) + f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind); + else if (f->value.function.isym->id == GFC_ISYM_SHIFTL) + f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind); + else if (f->value.function.isym->id == GFC_ISYM_SHIFTR) + f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind); + else + gcc_unreachable (); +} + + +void gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED) { f->ts = a->ts; @@ -2297,34 +2460,21 @@ gfc_resolve_ftell (gfc_expr *f, gfc_expr *u) void -gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED, + gfc_expr *kind) { - const char *name; - - f->ts = array->ts; - - if (mask) - { - if (mask->rank == 0) - name = "ssum"; - else - name = "msum"; - - resolve_mask_arg (mask); - } + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); else - name = "sum"; + f->ts.kind = gfc_default_integer_kind; +} - if (dim != NULL) - { - f->rank = array->rank - 1; - f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim); - gfc_resolve_dim_arg (dim); - } - f->value.function.name - = gfc_get_string (PREFIX ("%s_%c%d"), name, - gfc_type_letter (array->ts.type), array->ts.kind); +void +gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + resolve_transformational ("sum", f, array, dim, mask); } @@ -2368,6 +2518,23 @@ gfc_resolve_tanh (gfc_expr *f, gfc_expr *x) void +gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, + gfc_expr *sub ATTRIBUTE_UNUSED) +{ + static char this_image[] = "__image_index"; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = this_image; +} + + +void +gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim) +{ + resolve_bound (f, array, dim, NULL, "__this_image", true); +} + + +void gfc_resolve_time (gfc_expr *f) { f->ts.type = BT_INTEGER; @@ -2398,11 +2565,17 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED, { int len; if (mold->expr_type == EXPR_CONSTANT) - mold->ts.u.cl->length = gfc_int_expr (mold->value.character.length); + { + len = mold->value.character.length; + mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + NULL, len); + } else { - len = mold->value.constructor->expr->value.character.length; - mold->ts.u.cl->length = gfc_int_expr (len); + gfc_constructor *c = gfc_constructor_first (mold->value.constructor); + len = c->expr->value.character.length; + mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + NULL, len); } } @@ -2496,22 +2669,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) { - static char ubound[] = "__ubound"; - - f->ts.type = BT_INTEGER; - if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = gfc_default_integer_kind; + resolve_bound (f, array, dim, kind, "__ubound", false); +} - if (dim == NULL) - { - f->rank = 1; - f->shape = gfc_get_shape (1); - mpz_init_set_ui (f->shape[0], array->rank); - } - f->value.function.name = ubound; +void +gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + resolve_bound (f, array, dim, kind, "__ucobound", true); } @@ -3056,6 +3221,17 @@ gfc_resolve_system_clock (gfc_code *c) } +/* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */ +void +gfc_resolve_execute_command_line (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("execute_command_line_i%d"), + gfc_default_integer_kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + /* Resolve the EXIT intrinsic subroutine. */ void diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def index fa6071f45b2..6c009f1c8fd 100644 --- a/gcc/fortran/iso-fortran-env.def +++ b/gcc/fortran/iso-fortran-env.def @@ -1,4 +1,4 @@ -/* Copyright (C) 2006, 2007, 2008 Free Software Foundation, Inc. +/* Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. This file is part of GCC. @@ -25,6 +25,10 @@ along with GCC; see the file COPYING3. If not see -- the value it has -- the standard that supports this type */ +NAMED_INTCST (ISOFORTRANENV_FILE_ATOMIC_INT_KIND, "atomic_int_kind", \ + gfc_default_integer_kind, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_FILE_ATOMIC_LOGICAL_KIND, "atomic_logical_kind", \ + gfc_default_logical_kind, GFC_STD_F2008) NAMED_INTCST (ISOFORTRANENV_CHARACTER_STORAGE_SIZE, "character_storage_size", \ gfc_character_storage_size, GFC_STD_F2003) NAMED_INTCST (ISOFORTRANENV_ERROR_UNIT, "error_unit", GFC_STDERR_UNIT_NUMBER, \ @@ -45,6 +49,9 @@ NAMED_INTCST (ISOFORTRANENV_IOSTAT_END, "iostat_end", LIBERROR_END, \ GFC_STD_F2003) NAMED_INTCST (ISOFORTRANENV_IOSTAT_EOR, "iostat_eor", LIBERROR_EOR, \ GFC_STD_F2003) +NAMED_INTCST (ISOFORTRANENV_IOSTAT_INQUIRE_INTERNAL_UNIT, \ + "iostat_inquire_internal_unit", GFC_INQUIRE_INTERNAL_UNIT, \ + GFC_STD_F2008) NAMED_INTCST (ISOFORTRANENV_NUMERIC_STORAGE_SIZE, "numeric_storage_size", \ gfc_numeric_storage_size, GFC_STD_F2003) NAMED_INTCST (ISOFORTRANENV_OUTPUT_UNIT, "output_unit", GFC_STDOUT_UNIT_NUMBER, \ @@ -55,3 +62,13 @@ NAMED_INTCST (ISOFORTRANENV_REAL64, "real64", \ gfc_get_real_kind_from_width_isofortranenv (64), GFC_STD_F2008) NAMED_INTCST (ISOFORTRANENV_REAL128, "real128", \ gfc_get_real_kind_from_width_isofortranenv (128), GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED, "stat_locked", \ + GFC_STAT_LOCKED, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED_OTHER_IMAGE, \ + "stat_locked_other_image", \ + GFC_STAT_LOCKED_OTHER_IMAGE, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_FILE_STAT_STOPPED_IMAGE, "stat_stopped_image", \ + GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_FILE_STAT_UNLOCKED, "stat_unlocked", \ + GFC_STAT_UNLOCKED, GFC_STD_F2008) + diff --git a/gcc/fortran/lang-specs.h b/gcc/fortran/lang-specs.h index a622dcb1a6a..73bfc89ec0b 100644 --- a/gcc/fortran/lang-specs.h +++ b/gcc/fortran/lang-specs.h @@ -1,6 +1,6 @@ /* Contribution to the specs for the GNU Compiler Collection from GNU Fortran 95 compiler. - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2010 Free Software Foundation, Inc. This file is free software; you can redistribute it and/or modify @@ -28,9 +28,9 @@ %{O*} %{undef}" /* Options that f951 should know about, even if not preprocessing. */ -#define CPP_FORWARD_OPTIONS "%{i*} %{I*}" +#define CPP_FORWARD_OPTIONS "%{i*} %{I*} %{M*}" -#define F951_CPP_OPTIONS "%{!nocpp: -cpp %g.f90 %{E} %(cpp_unique_options) \ +#define F951_CPP_OPTIONS "%{!nocpp: -cpp=%g.f90 %{E} %(cpp_unique_options) \ %{E|M|MM:%(cpp_debug_options) " CPP_ONLY_OPTIONS \ " -fsyntax-only};: " CPP_FORWARD_OPTIONS "}" #define F951_OPTIONS "%(cc1_options) %{J*} \ diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 751749e6b58..a5a785b1b7c 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -56,6 +56,42 @@ J Fortran Joined Separate -J<directory> Put MODULE files in 'directory' +M +Fortran +; Documented in C + +MD +Fortran Separate NoDriverArg +; Documented in C + +MF +Fortran Joined Separate +; Documented in C + +MG +Fortran +; Documented in C + +MM +Fortran +; Documented in C + +MMD +Fortran Separate NoDriverArg +; Documented in C + +MP +Fortran +; Documented in C + +MT +Fortran Joined Separate +; Documented in C + +MQ +Fortran Joined Separate +; Documented in C + P Fortran ; Documented in C @@ -92,6 +128,10 @@ Wconversion Fortran Warning ; Documented in C +Wconversion-extra +Fortran Warning +Warn about most implicit conversions + Wimplicit-interface Fortran Warning Warn about calls with implicit interface @@ -128,10 +168,18 @@ Wintrinsic-shadow Fortran Warning Warn if a user-procedure has the same name as an intrinsic +Wunused-dummy-argument +Fortran Warning +Warn about unused dummy arguments. + cpp -Fortran Joined Separate Negative(nocpp) +Fortran Negative(nocpp) Enable preprocessing +cpp= +Fortran Joined Negative(nocpp) Undocumented +; Internal option generated by specs from -cpp. + nocpp Fortran Negative(cpp) Disable preprocessing @@ -348,6 +396,10 @@ frepack-arrays Fortran Copy array sections into a contiguous block on procedure entry +fcoarray= +Fortran RejectNegative JoinedOrMissing +-fcoarray=[...] Specify which coarray parallelization should be used + fcheck= Fortran RejectNegative JoinedOrMissing -fcheck=[...] Specify which runtime checks are to be performed @@ -357,7 +409,7 @@ Fortran Append a second underscore if the name already contains an underscore fshort-enums -Fortran +Fortran Var(flag_short_enums) VarExists ; Documented in C fsign-zero diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index ca0da517611..d9216d30149 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -23,15 +23,16 @@ along with GCC; see the file COPYING3. If not see Note that no features were obsoleted nor deleted in F2003. Please remember to keep those definitions in sync with gfortran.texi. */ -#define GFC_STD_F2008 (1<<7) /* New in F2008. */ -#define GFC_STD_LEGACY (1<<6) /* Backward compatibility. */ -#define GFC_STD_GNU (1<<5) /* GNU Fortran extension. */ -#define GFC_STD_F2003 (1<<4) /* New in F2003. */ -#define GFC_STD_F95 (1<<3) /* New in F95. */ -#define GFC_STD_F95_DEL (1<<2) /* Deleted in F95. */ -#define GFC_STD_F95_OBS (1<<1) /* Obsolescent in F95. */ -#define GFC_STD_F77 (1<<0) /* Included in F77, but not deleted or - obsolescent in later standards. */ +#define GFC_STD_F2008_OBS (1<<8) /* Obsolescent in F2008. */ +#define GFC_STD_F2008 (1<<7) /* New in F2008. */ +#define GFC_STD_LEGACY (1<<6) /* Backward compatibility. */ +#define GFC_STD_GNU (1<<5) /* GNU Fortran extension. */ +#define GFC_STD_F2003 (1<<4) /* New in F2003. */ +#define GFC_STD_F95 (1<<3) /* New in F95. */ +#define GFC_STD_F95_DEL (1<<2) /* Deleted in F95. */ +#define GFC_STD_F95_OBS (1<<1) /* Obsolescent in F95. */ +#define GFC_STD_F77 (1<<0) /* Included in F77, but not deleted or + obsolescent in later standards. */ /* Bitmasks for the various FPE that can be enabled. */ @@ -96,6 +97,15 @@ typedef enum } libgfortran_error_codes; +typedef enum +{ + GFC_STAT_UNLOCKED = 0, + GFC_STAT_LOCKED, + GFC_STAT_LOCKED_OTHER_IMAGE, + GFC_STAT_STOPPED_IMAGE, + GFC_INQUIRE_INTERNAL_UNIT /* Must be different from STAT_STOPPED_IMAGE. */ +} +libgfortran_stat_codes; /* Default unit number for preconnected standard input and output. */ #define GFC_STDIN_UNIT_NUMBER 5 diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 48bb733b940..ff0ef44f64a 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1,5 +1,6 @@ /* Matching subroutines in all sizes, shapes and colors. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, + 2009, 2010 2010 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -949,6 +950,8 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag) locus start; match m; + e1 = e2 = e3 = NULL; + /* Match the start of an iterator without affecting the symbol table. */ start = gfc_current_locus; @@ -962,9 +965,12 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag) if (m != MATCH_YES) return MATCH_NO; - gfc_match_char ('='); - - e1 = e2 = e3 = NULL; + /* F2008, C617 & C565. */ + if (var->symtree->n.sym->attr.codimension) + { + gfc_error ("Loop variable at %C cannot be a coarray"); + goto cleanup; + } if (var->ref != NULL) { @@ -979,6 +985,8 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag) goto cleanup; } + gfc_match_char ('='); + var->symtree->n.sym->attr.implied_index = 1; m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1); @@ -998,7 +1006,7 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag) if (gfc_match_char (',') != MATCH_YES) { - e3 = gfc_int_expr (1); + e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); goto done; } @@ -1743,6 +1751,12 @@ gfc_match_critical (void) == FAILURE) return MATCH_ERROR; + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return MATCH_ERROR; + } + if (gfc_find_state (COMP_CRITICAL) == SUCCESS) { gfc_error ("Nested CRITICAL block at %C"); @@ -1783,6 +1797,100 @@ gfc_match_block (void) } +/* Match an ASSOCIATE statement. */ + +match +gfc_match_associate (void) +{ + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" associate") != MATCH_YES) + return MATCH_NO; + + /* Match the association list. */ + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_error ("Expected association list at %C"); + return MATCH_ERROR; + } + new_st.ext.block.assoc = NULL; + while (true) + { + gfc_association_list* newAssoc = gfc_get_association_list (); + gfc_association_list* a; + + /* Match the next association. */ + if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target) + != MATCH_YES) + { + gfc_error ("Expected association at %C"); + goto assocListError; + } + newAssoc->where = gfc_current_locus; + + /* Check that the current name is not yet in the list. */ + for (a = new_st.ext.block.assoc; a; a = a->next) + if (!strcmp (a->name, newAssoc->name)) + { + gfc_error ("Duplicate name '%s' in association at %C", + newAssoc->name); + goto assocListError; + } + + /* The target expression must not be coindexed. */ + if (gfc_is_coindexed (newAssoc->target)) + { + gfc_error ("Association target at %C must not be coindexed"); + goto assocListError; + } + + /* The `variable' field is left blank for now; because the target is not + yet resolved, we can't use gfc_has_vector_subscript to determine it + for now. Instead, if the symbol is matched as variable, this field + is set -- and during resolution we check that. */ + newAssoc->variable = 0; + + /* Put it into the list. */ + newAssoc->next = new_st.ext.block.assoc; + new_st.ext.block.assoc = newAssoc; + + /* Try next one or end if closing parenthesis is found. */ + gfc_gobble_whitespace (); + if (gfc_peek_char () == ')') + break; + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected ')' or ',' at %C"); + return MATCH_ERROR; + } + + continue; + +assocListError: + gfc_free (newAssoc); + goto error; + } + if (gfc_match_char (')') != MATCH_YES) + { + /* This should never happen as we peek above. */ + gcc_unreachable (); + } + + if (gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after ASSOCIATE statement at %C"); + goto error; + } + + return MATCH_YES; + +error: + gfc_free_association_list (new_st.ext.block.assoc); + return MATCH_ERROR; +} + + /* Match a DO statement. */ match @@ -1813,7 +1921,7 @@ gfc_match_do (void) if (gfc_match_eos () == MATCH_YES) { - iter.end = gfc_logical_expr (1, NULL); + iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true); new_st.op = EXEC_DO_WHILE; goto done; } @@ -1894,12 +2002,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) @@ -1908,19 +2020,29 @@ 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)); + gfc_error ("Name '%s' in %s statement at %C is not a construct name", + 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; - else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK) + if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK) o = p; else if (p->state == COMP_CRITICAL) { @@ -1928,40 +2050,94 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) gfc_ascii_statement (st)); return MATCH_ERROR; } + else if ((sym && sym == p->sym) || (!sym && p->state == COMP_DO)) + break; if (p == NULL) { if (sym == NULL) - gfc_error ("%s statement at %C is not within a loop", + gfc_error ("%s statement at %C is not within a construct", gfc_ascii_statement (st)); else - gfc_error ("%s statement at %C is not within loop '%s'", + gfc_error ("%s statement at %C is not within construct '%s'", gfc_ascii_statement (st), sym->name); return MATCH_ERROR; } + /* Special checks for EXIT from non-loop constructs. */ + switch (p->state) + { + case COMP_DO: + break; + + case COMP_CRITICAL: + /* This is already handled above. */ + gcc_unreachable (); + + case COMP_ASSOCIATE: + case COMP_BLOCK: + case COMP_IF: + case COMP_SELECT: + case COMP_SELECT_TYPE: + gcc_assert (sym); + if (op == EXEC_CYCLE) + { + gfc_error ("CYCLE statement at %C is not applicable to non-loop" + " construct '%s'", sym->name); + return MATCH_ERROR; + } + gcc_assert (op == EXEC_EXIT); + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: EXIT statement with no" + " do-construct-name at %C") == FAILURE) + return MATCH_ERROR; + break; + + default: + gfc_error ("%s statement at %C is not applicable to construct '%s'", + gfc_ascii_statement (st), sym->name); + return MATCH_ERROR; + } + if (o != NULL) { gfc_error ("%s statement at %C leaving OpenMP structured block", 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. */ - new_st.ext.whichloop = p->head; + /* Save the first statement in the construct - needed by the backend. */ + new_st.ext.which_construct = p->construct; new_st.op = op; @@ -1992,37 +2168,18 @@ gfc_match_cycle (void) static match gfc_match_stopcode (gfc_statement st) { - int stop_code; gfc_expr *e; match m; - int cnt; - stop_code = -1; e = NULL; if (gfc_match_eos () != MATCH_YES) { - m = gfc_match_small_literal_int (&stop_code, &cnt); + m = gfc_match_init_expr (&e); if (m == MATCH_ERROR) goto cleanup; - - if (m == MATCH_YES && cnt > 5) - { - gfc_error ("Too many digits in STOP code at %C"); - goto cleanup; - } - if (m == MATCH_NO) - { - /* Try a character constant. */ - m = gfc_match_expr (&e); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) - goto syntax; - } + goto syntax; if (gfc_match_eos () != MATCH_YES) goto syntax; @@ -2038,7 +2195,40 @@ gfc_match_stopcode (gfc_statement st) if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS) { gfc_error ("Image control statement STOP at %C in CRITICAL block"); - return MATCH_ERROR; + goto cleanup; + } + + if (e != NULL) + { + if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER)) + { + gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type", + &e->where); + goto cleanup; + } + + if (e->rank != 0) + { + gfc_error ("STOP code at %L must be scalar", + &e->where); + goto cleanup; + } + + if (e->ts.type == BT_CHARACTER + && e->ts.kind != gfc_default_character_kind) + { + gfc_error ("STOP code at %L must be default character KIND=%d", + &e->where, (int) gfc_default_character_kind); + goto cleanup; + } + + if (e->ts.type == BT_INTEGER + && e->ts.kind != gfc_default_integer_kind) + { + gfc_error ("STOP code at %L must be default integer KIND=%d", + &e->where, (int) gfc_default_integer_kind); + goto cleanup; + } } switch (st) @@ -2057,7 +2247,7 @@ gfc_match_stopcode (gfc_statement st) } new_st.expr1 = e; - new_st.ext.stop_code = stop_code; + new_st.ext.stop_code = -1; return MATCH_YES; @@ -2138,6 +2328,12 @@ sync_statement (gfc_statement st) == FAILURE) return MATCH_ERROR; + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return MATCH_ERROR; + } + if (gfc_find_state (COMP_CRITICAL) == SUCCESS) { gfc_error ("Image control statement SYNC at %C in CRITICAL block"); @@ -2445,7 +2641,8 @@ gfc_match_goto (void) } cp = gfc_get_case (); - cp->low = cp->high = gfc_int_expr (i++); + cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind, + NULL, i++); tail->op = EXEC_SELECT; tail->ext.case_list = cp; @@ -2549,7 +2746,7 @@ match_derived_type_spec (gfc_typespec *ts) gfc_match_decl_type_spec() from decl.c, with the following exceptions: It only includes the intrinsic types from the Fortran 2003 standard (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally, - the implicit_flag is not needed, so it was removed. Derived types are + the implicit_flag is not needed, so it was removed. Derived types are identified by their name alone. */ static match @@ -2559,8 +2756,30 @@ match_type_spec (gfc_typespec *ts) locus old_locus; gfc_clear_ts (ts); + gfc_gobble_whitespace(); old_locus = gfc_current_locus; + m = match_derived_type_spec (ts); + if (m == MATCH_YES) + { + old_locus = gfc_current_locus; + if (gfc_match (" :: ") != MATCH_YES) + return MATCH_ERROR; + gfc_current_locus = old_locus; + /* Enfore F03:C401. */ + if (ts->u.derived->attr.abstract) + { + gfc_error ("Derived type '%s' at %L may not be ABSTRACT", + ts->u.derived->name, &old_locus); + return MATCH_ERROR; + } + return MATCH_YES; + } + else if (m == MATCH_ERROR && gfc_match (" :: ") == MATCH_YES) + return MATCH_ERROR; + + gfc_current_locus = old_locus; + if (gfc_match ("integer") == MATCH_YES) { ts->type = BT_INTEGER; @@ -2602,25 +2821,6 @@ match_type_spec (gfc_typespec *ts) goto kind_selector; } - m = match_derived_type_spec (ts); - if (m == MATCH_YES) - { - old_locus = gfc_current_locus; - if (gfc_match (" :: ") != MATCH_YES) - return MATCH_ERROR; - gfc_current_locus = old_locus; - /* Enfore F03:C401. */ - if (ts->u.derived->attr.abstract) - { - gfc_error ("Derived type '%s' at %L may not be ABSTRACT", - ts->u.derived->name, &old_locus); - return MATCH_ERROR; - } - return MATCH_YES; - } - else if (m == MATCH_ERROR && gfc_match (" :: ") == MATCH_YES) - return MATCH_ERROR; - /* If a type is not matched, simply return MATCH_NO. */ gfc_current_locus = old_locus; return MATCH_NO; @@ -2658,16 +2858,16 @@ match gfc_match_allocate (void) { gfc_alloc *head, *tail; - gfc_expr *stat, *errmsg, *tmp, *source; + gfc_expr *stat, *errmsg, *tmp, *source, *mold; gfc_typespec ts; gfc_symbol *sym; match m; locus old_locus; - bool saw_stat, saw_errmsg, saw_source, b1, b2, b3; + bool saw_stat, saw_errmsg, saw_source, saw_mold, b1, b2, b3; head = tail = NULL; - stat = errmsg = source = tmp = NULL; - saw_stat = saw_errmsg = saw_source = false; + stat = errmsg = source = mold = tmp = NULL; + saw_stat = saw_errmsg = saw_source = saw_mold = false; if (gfc_match_char ('(') != MATCH_YES) goto syntax; @@ -2750,8 +2950,8 @@ gfc_match_allocate (void) && (tail->expr->ref->type == REF_COMPONENT || tail->expr->ref->type == REF_ARRAY)); if (sym && sym->ts.type == BT_CLASS) - b2 = !(sym->ts.u.derived->components->attr.allocatable - || sym->ts.u.derived->components->attr.pointer); + b2 = !(CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.class_pointer); else b2 = sym && !(sym->attr.allocatable || sym->attr.pointer || sym->attr.proc_pointer); @@ -2790,6 +2990,7 @@ alloc_opt_list: } stat = tmp; + tmp = NULL; saw_stat = true; if (gfc_check_do_variable (stat->symtree)) @@ -2816,6 +3017,7 @@ alloc_opt_list: } errmsg = tmp; + tmp = NULL; saw_errmsg = true; if (gfc_match_char (',') == MATCH_YES) @@ -2854,12 +3056,46 @@ alloc_opt_list: } source = tmp; + tmp = NULL; saw_source = true; if (gfc_match_char (',') == MATCH_YES) goto alloc_opt_list; } + m = gfc_match (" mold = %e", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L", + &tmp->where) == FAILURE) + goto cleanup; + + /* Check F08:C636. */ + if (saw_mold) + { + gfc_error ("Redundant MOLD tag found at %L ", &tmp->where); + goto cleanup; + } + + /* Check F08:C637. */ + if (ts.type != BT_UNKNOWN) + { + gfc_error ("MOLD tag at %L conflicts with the typespec at %L", + &tmp->where, &old_locus); + goto cleanup; + } + + mold = tmp; + tmp = NULL; + saw_mold = true; + mold->mold = 1; + + if (gfc_match_char (',') == MATCH_YES) + goto alloc_opt_list; + } + gfc_gobble_whitespace (); if (gfc_peek_char () == ')') @@ -2870,10 +3106,21 @@ alloc_opt_list: if (gfc_match (" )%t") != MATCH_YES) goto syntax; + /* Check F08:C637. */ + if (source && mold) + { + gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L", + &mold->where, &source->where); + goto cleanup; + } + new_st.op = EXEC_ALLOCATE; new_st.expr1 = stat; new_st.expr2 = errmsg; - new_st.expr3 = source; + if (source) + new_st.expr3 = source; + else + new_st.expr3 = mold; new_st.ext.alloc.list = head; new_st.ext.alloc.ts = ts; @@ -2886,7 +3133,8 @@ cleanup: gfc_free_expr (errmsg); gfc_free_expr (source); gfc_free_expr (stat); - gfc_free_expr (tmp); + gfc_free_expr (mold); + if (tmp && tmp->expr_type) gfc_free_expr (tmp); gfc_free_alloc_list (head); return MATCH_ERROR; } @@ -2925,10 +3173,7 @@ gfc_match_nullify (void) } /* build ' => NULL() '. */ - e = gfc_get_expr (); - e->where = gfc_current_locus; - e->expr_type = EXPR_NULL; - e->ts.type = BT_UNKNOWN; + e = gfc_get_null_expr (&gfc_current_locus); /* Chain to list. */ if (tail == NULL) @@ -3015,8 +3260,8 @@ gfc_match_deallocate (void) && (tail->expr->ref->type == REF_COMPONENT || tail->expr->ref->type == REF_ARRAY)); if (sym && sym->ts.type == BT_CLASS) - b2 = !(sym->ts.u.derived->components->attr.allocatable - || sym->ts.u.derived->components->attr.pointer); + b2 = !(CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.class_pointer); else b2 = sym && !(sym->attr.allocatable || sym->attr.pointer || sym->attr.proc_pointer); @@ -3336,7 +3581,8 @@ gfc_match_call (void) c->op = EXEC_SELECT; new_case = gfc_get_case (); - new_case->high = new_case->low = gfc_int_expr (i); + new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i); + new_case->low = new_case->high; c->ext.case_list = new_case; c->next = gfc_get_code (); @@ -3562,7 +3808,7 @@ gfc_match_common (void) /* Deal with an optional array specification after the symbol name. */ - m = gfc_match_array_spec (&as); + m = gfc_match_array_spec (&as, true, true); if (m == MATCH_ERROR) goto cleanup; @@ -3833,18 +4079,25 @@ gfc_match_module (void) do this. */ void -gfc_free_equiv (gfc_equiv *eq) +gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop) { - if (eq == NULL) + if (eq == stop) return; gfc_free_equiv (eq->eq); - gfc_free_equiv (eq->next); + gfc_free_equiv_until (eq->next, stop); gfc_free_expr (eq->expr); gfc_free (eq); } +void +gfc_free_equiv (gfc_equiv *eq) +{ + gfc_free_equiv_until (eq, NULL); +} + + /* Match an EQUIVALENCE statement. */ match @@ -4246,6 +4499,12 @@ select_type_set_tmp (gfc_typespec *ts) char name[GFC_MAX_SYMBOL_LEN]; gfc_symtree *tmp; + if (!ts) + { + select_type_stack->tmp = NULL; + return; + } + if (!gfc_type_is_extensible (ts->u.derived)) return; @@ -4261,10 +4520,16 @@ select_type_set_tmp (gfc_typespec *ts) if (ts->type == BT_CLASS) { gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, - &tmp->n.sym->as); + &tmp->n.sym->as, false); tmp->n.sym->attr.class_ok = 1; } + /* Add an association for it, so the rest of the parser knows it is + an associate-name. The target will be set during resolution. */ + tmp->n.sym->assoc = gfc_get_association_list (); + tmp->n.sym->assoc->dangling = 1; + tmp->n.sym->assoc->st = tmp; + select_type_stack->tmp = tmp; } @@ -4294,8 +4559,15 @@ gfc_match_select_type (void) expr1 = gfc_get_expr(); expr1->expr_type = EXPR_VARIABLE; if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) - return MATCH_ERROR; - expr1->symtree->n.sym->ts = expr2->ts; + { + m = MATCH_ERROR; + goto cleanup; + } + if (expr2->ts.type == BT_UNKNOWN) + expr1->symtree->n.sym->attr.untyped = 1; + else + expr1->symtree->n.sym->ts = expr2->ts; + expr1->symtree->n.sym->attr.flavor = FL_VARIABLE; expr1->symtree->n.sym->attr.referenced = 1; expr1->symtree->n.sym->attr.class_ok = 1; } @@ -4303,37 +4575,34 @@ gfc_match_select_type (void) { m = gfc_match (" %e ", &expr1); if (m != MATCH_YES) - return m; + goto cleanup; } m = gfc_match (" )%t"); if (m != MATCH_YES) - return m; + goto cleanup; /* Check for F03:C811. */ if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL)) { gfc_error ("Selector in SELECT TYPE at %C is not a named variable; " "use associate-name=>"); - return MATCH_ERROR; - } - - /* Check for F03:C813. */ - if (expr1->ts.type != BT_CLASS && !(expr2 && expr2->ts.type == BT_CLASS)) - { - gfc_error ("Selector shall be polymorphic in SELECT TYPE statement " - "at %C"); - return MATCH_ERROR; + m = MATCH_ERROR; + goto cleanup; } new_st.op = EXEC_SELECT_TYPE; new_st.expr1 = expr1; new_st.expr2 = expr2; - new_st.ext.ns = gfc_current_ns; + new_st.ext.block.ns = gfc_current_ns; select_type_push (expr1->symtree->n.sym); return MATCH_YES; + +cleanup: + gfc_current_ns = gfc_current_ns->parent; + return m; } @@ -4485,6 +4754,7 @@ gfc_match_class_is (void) c->where = gfc_current_locus; c->ts.type = BT_UNKNOWN; new_st.ext.case_list = c; + select_type_set_tmp (NULL); return MATCH_YES; } @@ -4767,7 +5037,7 @@ match_forall_iterator (gfc_forall_iterator **result) goto cleanup; if (gfc_match_char (':') == MATCH_NO) - iter->stride = gfc_int_expr (1); + iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); else { m = gfc_match_expr (&iter->stride); diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index b03ee541819..501049e1220 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -23,8 +23,6 @@ along with GCC; see the file COPYING3. If not see #ifndef GFC_MATCH_H #define GFC_MATCH_H -#include "gfortran.h" - /* gfc_new_block points to the symbol of a newly matched block. */ extern gfc_symbol *gfc_new_block; @@ -71,6 +69,7 @@ match gfc_match_else (void); match gfc_match_elseif (void); match gfc_match_critical (void); match gfc_match_block (void); +match gfc_match_associate (void); match gfc_match_do (void); match gfc_match_cycle (void); match gfc_match_exit (void); @@ -168,6 +167,8 @@ void gfc_set_constant_character_len (int, gfc_expr *, int); /* Matchers for attribute declarations. */ match gfc_match_allocatable (void); match gfc_match_asynchronous (void); +match gfc_match_codimension (void); +match gfc_match_contiguous (void); match gfc_match_dimension (void); match gfc_match_external (void); match gfc_match_gcc_attributes (void); @@ -214,8 +215,8 @@ gfc_try gfc_reduce_init_expr (gfc_expr *expr); match gfc_match_init_expr (gfc_expr **); /* array.c. */ -match gfc_match_array_spec (gfc_array_spec **); -match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int); +match gfc_match_array_spec (gfc_array_spec **, bool, bool); +match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int, int); match gfc_match_array_constructor (gfc_expr **); /* interface.c. */ diff --git a/gcc/fortran/matchexp.c b/gcc/fortran/matchexp.c index f66623f82d0..8b99ce98692 100644 --- a/gcc/fortran/matchexp.c +++ b/gcc/fortran/matchexp.c @@ -1,5 +1,5 @@ /* Expression parser. - Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009 + Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -130,14 +130,10 @@ gfc_get_parentheses (gfc_expr *e) { gfc_expr *e2; - e2 = gfc_get_expr(); - e2->expr_type = EXPR_OP; + e2 = gfc_get_operator_expr (&e->where, INTRINSIC_PARENTHESES, e, NULL); e2->ts = e->ts; e2->rank = e->rank; - e2->where = e->where; - e2->value.op.op = INTRINSIC_PARENTHESES; - e2->value.op.op1 = e; - e2->value.op.op2 = NULL; + return e2; } @@ -195,26 +191,6 @@ syntax: } -/* Build an operator expression node. */ - -static gfc_expr * -build_node (gfc_intrinsic_op op, locus *where, - gfc_expr *op1, gfc_expr *op2) -{ - gfc_expr *new_expr; - - new_expr = gfc_get_expr (); - new_expr->expr_type = EXPR_OP; - new_expr->value.op.op = op; - new_expr->where = *where; - - new_expr->value.op.op1 = op1; - new_expr->value.op.op2 = op2; - - return new_expr; -} - - /* Match a level 1 expression. */ static match @@ -239,7 +215,7 @@ match_level_1 (gfc_expr **result) *result = e; else { - f = build_node (INTRINSIC_USER, &where, e, NULL); + f = gfc_get_operator_expr (&where, INTRINSIC_USER, e, NULL); f->value.op.uop = uop; *result = f; } @@ -915,7 +891,7 @@ gfc_match_expr (gfc_expr **result) return MATCH_ERROR; } - all = build_node (INTRINSIC_USER, &where, all, e); + all = gfc_get_operator_expr (&where, INTRINSIC_USER, all, e); all->value.op.uop = uop; } diff --git a/gcc/fortran/mathbuiltins.def b/gcc/fortran/mathbuiltins.def index 3bedc1a6ba5..b3c52997a7f 100644 --- a/gcc/fortran/mathbuiltins.def +++ b/gcc/fortran/mathbuiltins.def @@ -51,3 +51,21 @@ DEFINE_MATH_BUILTIN (ERFC, "erfc", 0) DEFINE_MATH_BUILTIN (TGAMMA,"tgamma", 0) DEFINE_MATH_BUILTIN (LGAMMA,"lgamma", 0) DEFINE_MATH_BUILTIN (HYPOT, "hypot", 1) + +/* OTHER_BUILTIN (CODE, NAME, PROTOTYPE_TYPE, CONST) + For floating-point builtins that do not directly correspond to a + Fortran intrinsic. This is used to map the different variants (float, + double and long double) and to build the quad-precision decls. */ +OTHER_BUILTIN (CABS, "cabs", cabs, true) +OTHER_BUILTIN (COPYSIGN, "copysign", 2, true) +OTHER_BUILTIN (CPOW, "cpow", cpow, true) +OTHER_BUILTIN (FABS, "fabs", 1, true) +OTHER_BUILTIN (FMOD, "fmod", 2, true) +OTHER_BUILTIN (FREXP, "frexp", frexp, false) +OTHER_BUILTIN (LLROUND, "llround", llround, true) +OTHER_BUILTIN (LROUND, "lround", lround, true) +OTHER_BUILTIN (NEXTAFTER, "nextafter", 2, true) +OTHER_BUILTIN (POW, "pow", 1, true) +OTHER_BUILTIN (ROUND, "round", 1, true) +OTHER_BUILTIN (SCALBN, "scalbn", scalbn, true) +OTHER_BUILTIN (TRUNC, "trunc", 1, true) diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 0fc19214172..e9a8625212d 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -73,12 +73,14 @@ along with GCC; see the file COPYING3. If not see #include "match.h" #include "parse.h" /* FIXME */ #include "md5.h" +#include "constructor.h" +#include "cpp.h" #define MODULE_EXTENSION ".mod" /* Don't put any single quote (') in MOD_VERSION, if yout want it to be recognized. */ -#define MOD_VERSION "4" +#define MOD_VERSION "6" /* Structure that describes a position within a module file. */ @@ -1298,7 +1300,7 @@ static void write_char (char out) { if (putc (out, module_fp) == EOF) - gfc_fatal_error ("Error writing modules file: %s", strerror (errno)); + gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno)); /* Add this to our MD5. */ md5_process_bytes (&out, sizeof (out), &ctx); @@ -1672,7 +1674,8 @@ typedef enum AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP, 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_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION, + AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER } ab_attribute; @@ -1681,6 +1684,8 @@ static const mstring attr_bits[] = minit ("ALLOCATABLE", AB_ALLOCATABLE), minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS), minit ("DIMENSION", AB_DIMENSION), + minit ("CODIMENSION", AB_CODIMENSION), + minit ("CONTIGUOUS", AB_CONTIGUOUS), minit ("EXTERNAL", AB_EXTERNAL), minit ("INTRINSIC", AB_INTRINSIC), minit ("OPTIONAL", AB_OPTIONAL), @@ -1708,6 +1713,7 @@ static const mstring attr_bits[] = minit ("IS_ISO_C", AB_IS_ISO_C), minit ("VALUE", AB_VALUE), minit ("ALLOC_COMP", AB_ALLOC_COMP), + minit ("COARRAY_COMP", AB_COARRAY_COMP), minit ("POINTER_COMP", AB_POINTER_COMP), minit ("PRIVATE_COMP", AB_PRIVATE_COMP), minit ("ZERO_COMP", AB_ZERO_COMP), @@ -1716,6 +1722,9 @@ static const mstring attr_bits[] = minit ("IS_CLASS", AB_IS_CLASS), minit ("PROCEDURE", AB_PROCEDURE), minit ("PROC_POINTER", AB_PROC_POINTER), + minit ("VTYPE", AB_VTYPE), + minit ("VTAB", AB_VTAB), + minit ("CLASS_POINTER", AB_CLASS_POINTER), minit (NULL, -1) }; @@ -1798,6 +1807,10 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits); if (attr->dimension) MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits); + if (attr->codimension) + MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits); + if (attr->contiguous) + MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits); if (attr->external) MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits); if (attr->intrinsic) @@ -1806,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) @@ -1864,6 +1879,8 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits); if (attr->private_comp) MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits); + if (attr->coarray_comp) + MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits); if (attr->zero_comp) MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits); if (attr->is_class) @@ -1872,6 +1889,10 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits); if (attr->proc_pointer) MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits); + if (attr->vtype) + MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits); + if (attr->vtab) + MIO_NAME (ab_attribute) (AB_VTAB, attr_bits); mio_rparen (); @@ -1897,6 +1918,12 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_DIMENSION: attr->dimension = 1; break; + case AB_CODIMENSION: + attr->codimension = 1; + break; + case AB_CONTIGUOUS: + attr->contiguous = 1; + break; case AB_EXTERNAL: attr->external = 1; break; @@ -1909,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; @@ -1984,6 +2014,9 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_ALLOC_COMP: attr->alloc_comp = 1; break; + case AB_COARRAY_COMP: + attr->coarray_comp = 1; + break; case AB_POINTER_COMP: attr->pointer_comp = 1; break; @@ -2002,6 +2035,12 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_PROC_POINTER: attr->proc_pointer = 1; break; + case AB_VTYPE: + attr->vtype = 1; + break; + case AB_VTAB: + attr->vtab = 1; + break; } } } @@ -2131,9 +2170,10 @@ mio_array_spec (gfc_array_spec **asp) } mio_integer (&as->rank); + mio_integer (&as->corank); as->type = MIO_NAME (array_type) (as->type, array_spec_types); - for (i = 0; i < as->rank; i++) + for (i = 0; i < as->rank + as->corank; i++) { mio_expr (&as->lower[i]); mio_expr (&as->upper[i]); @@ -2303,7 +2343,7 @@ static void mio_formal_arglist (gfc_formal_arglist **formal); static void mio_typebound_proc (gfc_typebound_proc** proc); static void -mio_component (gfc_component *c) +mio_component (gfc_component *c, int vtype) { pointer_info *p; int n; @@ -2333,7 +2373,8 @@ mio_component (gfc_component *c) mio_symbol_attribute (&c->attr); c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types); - mio_expr (&c->initializer); + if (!vtype) + mio_expr (&c->initializer); if (c->attr.proc_pointer) { @@ -2368,7 +2409,7 @@ mio_component (gfc_component *c) static void -mio_component_list (gfc_component **cp) +mio_component_list (gfc_component **cp, int vtype) { gfc_component *c, *tail; @@ -2377,7 +2418,7 @@ mio_component_list (gfc_component **cp) if (iomode == IO_OUTPUT) { for (c = *cp; c; c = c->next) - mio_component (c); + mio_component (c, vtype); } else { @@ -2390,7 +2431,7 @@ mio_component_list (gfc_component **cp) break; c = gfc_get_component (); - mio_component (c); + mio_component (c, vtype); if (tail == NULL) *cp = c; @@ -2614,15 +2655,15 @@ done: static void -mio_constructor (gfc_constructor **cp) +mio_constructor (gfc_constructor_base *cp) { - gfc_constructor *c, *tail; + gfc_constructor *c; mio_lparen (); if (iomode == IO_OUTPUT) { - for (c = *cp; c; c = c->next) + for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c)) { mio_lparen (); mio_expr (&c->expr); @@ -2632,19 +2673,9 @@ mio_constructor (gfc_constructor **cp) } else { - *cp = NULL; - tail = NULL; - while (peek_atom () != ATOM_RPAREN) { - c = gfc_get_constructor (); - - if (tail == NULL) - *cp = c; - else - tail->next = c; - - tail = c; + c = gfc_constructor_append_expr (cp, NULL, NULL); mio_lparen (); mio_expr (&c->expr); @@ -3306,7 +3337,7 @@ mio_typebound_proc (gfc_typebound_proc** proc) if (iomode == IO_INPUT) { - *proc = gfc_get_typebound_proc (); + *proc = gfc_get_typebound_proc (NULL); (*proc)->where = gfc_current_locus; } gcc_assert (*proc); @@ -3567,7 +3598,7 @@ mio_symbol (gfc_symbol *sym) /* Note that components are always saved, even if they are supposed to be private. Component access is checked during searching. */ - mio_component_list (&sym->components); + mio_component_list (&sym->components, sym->attr.vtype); if (sym->components != NULL) sym->component_access @@ -4196,6 +4227,9 @@ check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info) if (st_sym == rsym) return false; + if (st_sym->attr.vtab || st_sym->attr.vtype) + return false; + /* If the existing symbol is generic from a different module and the new symbol is generic there can be no ambiguity. */ if (st_sym->attr.generic @@ -4337,6 +4371,11 @@ read_module (void) if (p == NULL && strcmp (name, module_name) == 0) p = name; + /* Exception: Always import vtabs & vtypes. */ + if (p == NULL && (strcmp (xstrndup (name,5), "vtab$") == 0 + || strcmp (xstrndup (name,6), "vtype$") == 0)) + p = name; + /* Skip symtree nodes not in an ONLY clause, unless there is an existing symtree loaded from another USE statement. */ if (p == NULL) @@ -5100,11 +5139,14 @@ gfc_dump_module (const char *name, int dump_flag) return; } + if (gfc_cpp_makedep ()) + gfc_cpp_add_target (filename); + /* Write the module to the temporary file. */ module_fp = fopen (filename_tmp, "w"); if (module_fp == NULL) gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s", - filename_tmp, strerror (errno)); + filename_tmp, xstrerror (errno)); /* Write the header, including space reserved for the MD5 sum. */ now = time (NULL); @@ -5142,7 +5184,7 @@ gfc_dump_module (const char *name, int dump_flag) if (fclose (module_fp)) gfc_fatal_error ("Error writing module file '%s' for writing: %s", - filename_tmp, strerror (errno)); + filename_tmp, xstrerror (errno)); /* Read the MD5 from the header of the old module file and compare. */ if (read_md5_from_module_file (filename, md5_old) != 0 @@ -5151,64 +5193,17 @@ gfc_dump_module (const char *name, int dump_flag) /* Module file have changed, replace the old one. */ if (unlink (filename) && errno != ENOENT) gfc_fatal_error ("Can't delete module file '%s': %s", filename, - strerror (errno)); + xstrerror (errno)); if (rename (filename_tmp, filename)) gfc_fatal_error ("Can't rename module file '%s' to '%s': %s", - filename_tmp, filename, strerror (errno)); + filename_tmp, filename, xstrerror (errno)); } else { if (unlink (filename_tmp)) gfc_fatal_error ("Can't delete temporary module file '%s': %s", - filename_tmp, strerror (errno)); - } -} - - -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; - } + filename_tmp, xstrerror (errno)); } - - gfc_rename_list = tmp_list; } @@ -5225,7 +5220,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); @@ -5250,57 +5244,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); + } } @@ -5329,7 +5298,7 @@ create_int_parameter (const char *name, int value, const char *modname, sym->attr.flavor = FL_PARAMETER; sym->ts.type = BT_INTEGER; sym->ts.kind = gfc_default_integer_kind; - sym->value = gfc_int_expr (value); + sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value); sym->attr.use_assoc = 1; sym->from_intmod = module; sym->intmod_sym_id = id; @@ -5342,7 +5311,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; @@ -5378,48 +5346,42 @@ 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"); - - 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 (!found && !only_flag) + { + if ((gfc_option.allow_std & symbol[i].standard) == 0) + continue; if ((gfc_option.flag_default_integer || gfc_option.flag_default_real) && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE) @@ -5429,19 +5391,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); - } } } @@ -5497,7 +5458,7 @@ gfc_use_module (void) if (module_fp == NULL) gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s", - filename, strerror (errno)); + filename, xstrerror (errno)); /* Check that we haven't already USEd an intrinsic module with the same name. */ diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index d60121c5929..6e8182118ce 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -1,5 +1,5 @@ /* OpenMP directive matching and resolving. - Copyright (C) 2005, 2006, 2007, 2008 + Copyright (C) 2005, 2006, 2007, 2008, 2010 Free Software Foundation, Inc. Contributed by Jakub Jelinek @@ -26,8 +26,6 @@ along with GCC; see the file COPYING3. If not see #include "match.h" #include "parse.h" #include "pointer-set.h" -#include "target.h" -#include "toplev.h" /* Match an end of OpenMP directive. End of OpenMP directive is optional whitespace, followed by '\n' or comment '!'. */ @@ -467,7 +465,10 @@ match gfc_match_omp_taskwait (void) { if (gfc_match_omp_eos () != MATCH_YES) - return MATCH_ERROR; + { + gfc_error ("Unexpected junk after TASKWAIT clause at %C"); + return MATCH_ERROR; + } new_st.op = EXEC_OMP_TASKWAIT; new_st.ext.omp_clauses = NULL; return MATCH_YES; @@ -482,7 +483,10 @@ gfc_match_omp_critical (void) if (gfc_match (" ( %n )", n) != MATCH_YES) n[0] = '\0'; if (gfc_match_omp_eos () != MATCH_YES) - return MATCH_ERROR; + { + gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C"); + return MATCH_ERROR; + } new_st.op = EXEC_OMP_CRITICAL; new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL; return MATCH_YES; @@ -508,6 +512,7 @@ gfc_match_omp_flush (void) gfc_match_omp_variable_list (" (", &list, true); if (gfc_match_omp_eos () != MATCH_YES) { + gfc_error ("Unexpected junk after $OMP FLUSH statement at %C"); gfc_free_namelist (list); return MATCH_ERROR; } @@ -654,7 +659,10 @@ match gfc_match_omp_workshare (void) { if (gfc_match_omp_eos () != MATCH_YES) - return MATCH_ERROR; + { + gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C"); + return MATCH_ERROR; + } new_st.op = EXEC_OMP_WORKSHARE; new_st.ext.omp_clauses = gfc_get_omp_clauses (); return MATCH_YES; @@ -665,7 +673,10 @@ match gfc_match_omp_master (void) { if (gfc_match_omp_eos () != MATCH_YES) - return MATCH_ERROR; + { + gfc_error ("Unexpected junk after $OMP MASTER statement at %C"); + return MATCH_ERROR; + } new_st.op = EXEC_OMP_MASTER; new_st.ext.omp_clauses = NULL; return MATCH_YES; @@ -676,7 +687,10 @@ match gfc_match_omp_ordered (void) { if (gfc_match_omp_eos () != MATCH_YES) - return MATCH_ERROR; + { + gfc_error ("Unexpected junk after $OMP ORDERED statement at %C"); + return MATCH_ERROR; + } new_st.op = EXEC_OMP_ORDERED; new_st.ext.omp_clauses = NULL; return MATCH_YES; @@ -687,7 +701,10 @@ match gfc_match_omp_atomic (void) { if (gfc_match_omp_eos () != MATCH_YES) - return MATCH_ERROR; + { + gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C"); + return MATCH_ERROR; + } new_st.op = EXEC_OMP_ATOMIC; new_st.ext.omp_clauses = NULL; return MATCH_YES; @@ -698,7 +715,10 @@ match gfc_match_omp_barrier (void) { if (gfc_match_omp_eos () != MATCH_YES) - return MATCH_ERROR; + { + gfc_error ("Unexpected junk after $OMP BARRIER statement at %C"); + return MATCH_ERROR; + } new_st.op = EXEC_OMP_BARRIER; new_st.ext.omp_clauses = NULL; return MATCH_YES; @@ -712,7 +732,10 @@ gfc_match_omp_end_nowait (void) if (gfc_match ("% nowait") == MATCH_YES) nowait = true; if (gfc_match_omp_eos () != MATCH_YES) - return MATCH_ERROR; + { + gfc_error ("Unexpected junk after NOWAIT clause at %C"); + return MATCH_ERROR; + } new_st.op = EXEC_OMP_END_NOWAIT; new_st.ext.omp_bool = nowait; return MATCH_YES; @@ -812,6 +835,8 @@ resolve_omp_clauses (gfc_code *code) if (el) continue; } + if (n->sym->attr.proc_pointer) + continue; } gfc_error ("Object '%s' is not a variable at %L", n->sym->name, &code->loc); @@ -820,11 +845,13 @@ resolve_omp_clauses (gfc_code *code) for (list = 0; list < OMP_LIST_NUM; list++) if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE) for (n = omp_clauses->lists[list]; n; n = n->next) - if (n->sym->mark) - gfc_error ("Symbol '%s' present on multiple clauses at %L", - n->sym->name, &code->loc); - else - n->sym->mark = 1; + { + if (n->sym->mark) + gfc_error ("Symbol '%s' present on multiple clauses at %L", + n->sym->name, &code->loc); + else + n->sym->mark = 1; + } gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1); for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++) @@ -837,22 +864,24 @@ resolve_omp_clauses (gfc_code *code) } for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next) - if (n->sym->mark) - gfc_error ("Symbol '%s' present on multiple clauses at %L", - n->sym->name, &code->loc); - else - n->sym->mark = 1; - + { + if (n->sym->mark) + gfc_error ("Symbol '%s' present on multiple clauses at %L", + n->sym->name, &code->loc); + else + n->sym->mark = 1; + } for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next) n->sym->mark = 0; for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next) - if (n->sym->mark) - gfc_error ("Symbol '%s' present on multiple clauses at %L", - n->sym->name, &code->loc); - else - n->sym->mark = 1; - + { + if (n->sym->mark) + gfc_error ("Symbol '%s' present on multiple clauses at %L", + n->sym->name, &code->loc); + else + n->sym->mark = 1; + } for (list = 0; list < OMP_LIST_NUM; list++) if ((n = omp_clauses->lists[list]) != NULL) { @@ -1367,7 +1396,6 @@ gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns) void gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym) { - struct omp_context *ctx; int i = omp_current_do_collapse; gfc_code *c = omp_current_do_code; @@ -1386,21 +1414,21 @@ gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym) c = c->block->next; } - for (ctx = omp_current_ctx; ctx; ctx = ctx->previous) - { - if (pointer_set_contains (ctx->sharing_clauses, sym)) - continue; + if (omp_current_ctx == NULL) + return; - if (! pointer_set_insert (ctx->private_iterators, sym)) - { - gfc_omp_clauses *omp_clauses = ctx->code->ext.omp_clauses; - gfc_namelist *p; + if (pointer_set_contains (omp_current_ctx->sharing_clauses, sym)) + return; - p = gfc_get_namelist (); - p->sym = sym; - p->next = omp_clauses->lists[OMP_LIST_PRIVATE]; - omp_clauses->lists[OMP_LIST_PRIVATE] = p; - } + if (! pointer_set_insert (omp_current_ctx->private_iterators, sym)) + { + gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses; + gfc_namelist *p; + + p = gfc_get_namelist (); + p->sym = sym; + p->next = omp_clauses->lists[OMP_LIST_PRIVATE]; + omp_clauses->lists[OMP_LIST_PRIVATE] = p; } } @@ -1488,7 +1516,8 @@ resolve_omp_do (gfc_code *code) break; } do_code = do_code->next; - if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE) + if (do_code == NULL + || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)) { gfc_error ("not enough DO loops for collapsed !$OMP DO at %L", &code->loc); diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index 0ad87f4e0e6..c49620a24f6 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" +#include "diagnostic-core.h" /* For sorry. */ #include "tm.h" gfc_option_t gfc_option; @@ -48,16 +48,26 @@ set_default_std_flags (void) { gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL | GFC_STD_F2003 | GFC_STD_F2008 | GFC_STD_F95 | GFC_STD_F77 - | GFC_STD_GNU | GFC_STD_LEGACY; + | GFC_STD_F2008_OBS | GFC_STD_GNU | GFC_STD_LEGACY; gfc_option.warn_std = GFC_STD_F95_DEL | GFC_STD_LEGACY; } +/* Return language mask for Fortran options. */ + +unsigned int +gfc_option_lang_mask (void) +{ + return CL_Fortran; +} + + /* Get ready for options handling. Keep in sync with libgfortran/runtime/compile_options.c (init_compile_options). */ -unsigned int -gfc_init_options (unsigned int argc, const char **argv) +void +gfc_init_options (unsigned int decoded_options_count, + struct cl_decoded_option *decoded_options) { gfc_source_file = NULL; gfc_option.module_dir = NULL; @@ -78,6 +88,7 @@ gfc_init_options (unsigned int argc, const char **argv) gfc_option.warn_character_truncation = 0; gfc_option.warn_array_temp = 0; gfc_option.warn_conversion = 0; + gfc_option.warn_conversion_extra = 0; gfc_option.warn_implicit_interface = 0; gfc_option.warn_line_truncation = 0; gfc_option.warn_surprising = 0; @@ -86,6 +97,7 @@ gfc_init_options (unsigned int argc, const char **argv) gfc_option.warn_intrinsic_shadow = 0; gfc_option.warn_intrinsics_std = 0; gfc_option.warn_align_commons = 1; + gfc_option.warn_unused_dummy_argument = 0; gfc_option.max_errors = 25; gfc_option.flag_all_intrinsics = 0; @@ -94,7 +106,7 @@ gfc_init_options (unsigned int argc, const char **argv) gfc_option.flag_default_real = 0; gfc_option.flag_dollar_ok = 0; gfc_option.flag_underscoring = 1; - gfc_option.flag_whole_file = 0; + gfc_option.flag_whole_file = 1; gfc_option.flag_f2c = 0; gfc_option.flag_second_underscore = -1; gfc_option.flag_implicit_none = 0; @@ -130,11 +142,10 @@ gfc_init_options (unsigned int argc, const char **argv) gfc_option.fpe = 0; gfc_option.rtcheck = 0; - - /* Argument pointers cannot point to anything but their argument. */ - flag_argument_noalias = 3; + gfc_option.coarray = GFC_FCOARRAY_NONE; flag_errno_math = 0; + flag_associative_math = -1; set_default_std_flags (); @@ -142,9 +153,7 @@ gfc_init_options (unsigned int argc, const char **argv) flag_short_enums = targetm.default_short_enums (); /* Initialize cpp-related options. */ - gfc_cpp_init_options(argc, argv); - - return CL_Fortran; + gfc_cpp_init_options (decoded_options_count, decoded_options); } @@ -248,6 +257,11 @@ gfc_post_options (const char **pfilename) if (flag_lto || flag_whopr) gfc_option.flag_whole_file = 1; + /* Fortran allows associative math - but we cannot reassociate if + we want traps or signed zeros. Cf. also flag_protect_parens. */ + if (flag_associative_math == -1) + flag_associative_math = (!flag_trapping_math && !flag_signed_zeros); + /* -fbounds-check is equivalent to -fcheck=bounds */ if (flag_bounds_check) gfc_option.rtcheck |= GFC_RTCHECK_BOUNDS; @@ -404,6 +418,7 @@ set_Wall (int setting) { gfc_option.warn_aliasing = setting; gfc_option.warn_ampersand = setting; + gfc_option.warn_conversion = setting; gfc_option.warn_line_truncation = setting; gfc_option.warn_surprising = setting; gfc_option.warn_tabs = !setting; @@ -411,18 +426,12 @@ set_Wall (int setting) gfc_option.warn_intrinsic_shadow = setting; gfc_option.warn_intrinsics_std = setting; gfc_option.warn_character_truncation = setting; + gfc_option.warn_unused_dummy_argument = setting; warn_unused = setting; warn_return_type = setting; warn_switch = setting; - - /* We save the value of warn_uninitialized, since if they put - -Wuninitialized on the command line, we need to generate a - warning about not using it without also specifying -O. */ - if (setting == 0) - warn_uninitialized = 0; - else if (warn_uninitialized != 1) - warn_uninitialized = 2; + warn_uninitialized = setting; } @@ -480,6 +489,18 @@ gfc_handle_fpe_trap_option (const char *arg) static void +gfc_handle_coarray_option (const char *arg) +{ + if (strcmp (arg, "none") == 0) + gfc_option.coarray = GFC_FCOARRAY_NONE; + else if (strcmp (arg, "single") == 0) + gfc_option.coarray = GFC_FCOARRAY_SINGLE; + else + gfc_fatal_error ("Argument to -fcoarray is not valid: %s", arg); +} + + +static void gfc_handle_runtime_check_option (const char *arg) { int result, pos = 0, n; @@ -521,23 +542,21 @@ gfc_handle_runtime_check_option (const char *arg) /* Handle command-line options. Returns 0 if unrecognized, 1 if recognized and handled. */ -int -gfc_handle_option (size_t scode, const char *arg, int value) +bool +gfc_handle_option (size_t scode, const char *arg, int value, + int kind ATTRIBUTE_UNUSED, + const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED) { - int result = 1; + bool result = true; enum opt_code code = (enum opt_code) scode; - /* Ignore file names. */ - if (code == N_OPTS) - return 1; - if (gfc_cpp_handle_option (scode, arg, value) == 1) - return 1; + return true; switch (code) { default: - result = 0; + result = false; break; case OPT_Wall: @@ -564,6 +583,10 @@ gfc_handle_option (size_t scode, const char *arg, int value) gfc_option.warn_conversion = value; break; + case OPT_Wconversion_extra: + gfc_option.warn_conversion_extra = value; + break; + case OPT_Wimplicit_interface: gfc_option.warn_implicit_interface = value; break; @@ -600,6 +623,10 @@ gfc_handle_option (size_t scode, const char *arg, int value) gfc_option.warn_align_commons = value; break; + case OPT_Wunused_dummy_argument: + gfc_option.warn_unused_dummy_argument = value; + break; + case OPT_fall_intrinsics: gfc_option.flag_all_intrinsics = 1; break; @@ -697,7 +724,7 @@ gfc_handle_option (size_t scode, const char *arg, int value) break; case OPT_fwhole_file: - gfc_option.flag_whole_file = 1; + gfc_option.flag_whole_file = value; break; case OPT_fsecond_underscore: @@ -839,7 +866,8 @@ gfc_handle_option (size_t scode, const char *arg, int value) break; case OPT_std_f95: - gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77; + gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77 + | GFC_STD_F2008_OBS; gfc_option.warn_std = GFC_STD_F95_OBS; gfc_option.max_continue_fixed = 19; gfc_option.max_continue_free = 39; @@ -850,7 +878,7 @@ gfc_handle_option (size_t scode, const char *arg, int value) case OPT_std_f2003: gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F77 - | GFC_STD_F2003 | GFC_STD_F95; + | GFC_STD_F2003 | GFC_STD_F95 | GFC_STD_F2008_OBS; gfc_option.warn_std = GFC_STD_F95_OBS; gfc_option.max_identifier_length = 63; gfc_option.warn_ampersand = 1; @@ -859,8 +887,8 @@ gfc_handle_option (size_t scode, const char *arg, int value) case OPT_std_f2008: gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F77 - | GFC_STD_F2003 | GFC_STD_F95 | GFC_STD_F2008; - gfc_option.warn_std = GFC_STD_F95_OBS; + | GFC_STD_F2003 | GFC_STD_F95 | GFC_STD_F2008 | GFC_STD_F2008_OBS; + gfc_option.warn_std = GFC_STD_F95_OBS | GFC_STD_F2008_OBS; gfc_option.max_identifier_length = 63; gfc_option.warn_ampersand = 1; gfc_option.warn_tabs = 0; @@ -880,7 +908,7 @@ gfc_handle_option (size_t scode, const char *arg, int value) break; case OPT_fshort_enums: - flag_short_enums = 1; + /* Handled in language-independent code. */ break; case OPT_fconvert_little_endian: @@ -916,7 +944,7 @@ gfc_handle_option (size_t scode, const char *arg, int value) break; case OPT_frecursive: - gfc_option.flag_recursive = 1; + gfc_option.flag_recursive = value; break; case OPT_falign_commons: @@ -931,6 +959,9 @@ gfc_handle_option (size_t scode, const char *arg, int value) gfc_handle_runtime_check_option (arg); break; + case OPT_fcoarray_: + gfc_handle_coarray_option (arg); + break; } return result; diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 7d935c33655..4632a250294 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -138,6 +138,8 @@ decode_specification_statement (void) break; case 'c': + match ("codimension", gfc_match_codimension, ST_ATTR_DECL); + match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); break; case 'd': @@ -234,9 +236,7 @@ decode_statement (void) match m; char c; -#ifdef GFC_DEBUG - gfc_symbol_state (); -#endif + gfc_enforce_clean_symbol_state (); gfc_clear_error (); /* Clear any pending errors. */ gfc_clear_warning (); /* Clear any pending warnings. */ @@ -291,7 +291,7 @@ decode_statement (void) gfc_undo_symbols (); gfc_current_locus = old_locus; - /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, and BLOCK + /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE statements, which might begin with a block label. The match functions for these statements are unusual in that their keyword is not seen before the matcher is called. */ @@ -313,6 +313,7 @@ decode_statement (void) match (NULL, gfc_match_do, ST_DO); match (NULL, gfc_match_block, ST_BLOCK); + match (NULL, gfc_match_associate, ST_ASSOCIATE); match (NULL, gfc_match_critical, ST_CRITICAL); match (NULL, gfc_match_select, ST_SELECT_CASE); match (NULL, gfc_match_select_type, ST_SELECT_TYPE); @@ -344,11 +345,13 @@ decode_statement (void) match ("call", gfc_match_call, ST_CALL); match ("close", gfc_match_close, ST_CLOSE); match ("continue", gfc_match_continue, ST_CONTINUE); + match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); match ("cycle", gfc_match_cycle, ST_CYCLE); match ("case", gfc_match_case, ST_CASE); match ("common", gfc_match_common, ST_COMMON); match ("contains", gfc_match_eos, ST_CONTAINS); match ("class", gfc_match_class_is, ST_CLASS_IS); + match ("codimension", gfc_match_codimension, ST_ATTR_DECL); break; case 'd': @@ -479,9 +482,7 @@ decode_omp_directive (void) locus old_locus; char c; -#ifdef GFC_DEBUG - gfc_symbol_state (); -#endif + gfc_enforce_clean_symbol_state (); gfc_clear_error (); /* Clear any pending errors. */ gfc_clear_warning (); /* Clear any pending warnings. */ @@ -583,9 +584,7 @@ decode_gcc_attribute (void) { locus old_locus; -#ifdef GFC_DEBUG - gfc_symbol_state (); -#endif + gfc_enforce_clean_symbol_state (); gfc_clear_error (); /* Clear any pending errors. */ gfc_clear_warning (); /* Clear any pending warnings. */ @@ -712,7 +711,9 @@ next_free (void) if (at_bol && c == ';') { - gfc_error_now ("Semicolon at %C needs to be preceded by statement"); + if (!(gfc_option.allow_std & GFC_STD_F2008)) + gfc_error_now ("Fortran 2008: Semicolon at %C without preceding " + "statement"); gfc_next_ascii_char (); /* Eat up the semicolon. */ return ST_NONE; } @@ -848,7 +849,11 @@ next_fixed (void) if (c == ';') { - gfc_error_now ("Semicolon at %C needs to be preceded by statement"); + if (digit_flag) + gfc_error_now ("Semicolon at %C needs to be preceded by statement"); + else if (!(gfc_option.allow_std & GFC_STD_F2008)) + gfc_error_now ("Fortran 2008: Semicolon at %C without preceding " + "statement"); return ST_NONE; } @@ -878,9 +883,12 @@ next_statement (void) gfc_statement st; locus old_locus; + gfc_enforce_clean_symbol_state (); + gfc_new_block = NULL; gfc_current_ns->old_cl_list = gfc_current_ns->cl_list; + gfc_current_ns->old_equiv = gfc_current_ns->equiv; for (;;) { gfc_statement_label = NULL; @@ -947,7 +955,7 @@ next_statement (void) /* Statements that mark other executable statements. */ #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \ - case ST_IF_BLOCK: case ST_BLOCK: \ + case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \ case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \ case ST_OMP_PARALLEL: \ case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \ @@ -968,7 +976,7 @@ next_statement (void) #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \ case ST_END_PROGRAM: case ST_END_SUBROUTINE: \ - case ST_END_BLOCK + case ST_END_BLOCK: case ST_END_ASSOCIATE /* Push a new state onto the stack. */ @@ -981,6 +989,13 @@ push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym) p->sym = sym; p->head = p->tail = NULL; p->do_variable = NULL; + + /* If this the state of a construct like BLOCK, DO or IF, the corresponding + construct statement was accepted right before pushing the state. Thus, + the construct's gfc_code is available as tail of the parent state. */ + gcc_assert (gfc_state_stack); + p->construct = gfc_state_stack->tail; + gfc_state_stack = p; } @@ -1153,6 +1168,9 @@ gfc_ascii_statement (gfc_statement st) case ST_ALLOCATE: p = "ALLOCATE"; break; + case ST_ASSOCIATE: + p = "ASSOCIATE"; + break; case ST_ATTR_DECL: p = _("attribute declaration"); break; @@ -1213,6 +1231,9 @@ gfc_ascii_statement (gfc_statement st) case ST_ELSEWHERE: p = "ELSEWHERE"; break; + case ST_END_ASSOCIATE: + p = "END ASSOCIATE"; + break; case ST_END_BLOCK: p = "END BLOCK"; break; @@ -1634,6 +1655,9 @@ reject_statement (void) gfc_free_charlen (gfc_current_ns->cl_list, gfc_current_ns->old_cl_list); gfc_current_ns->cl_list = gfc_current_ns->old_cl_list; + gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv); + gfc_current_ns->equiv = gfc_current_ns->old_equiv; + gfc_new_block = NULL; gfc_undo_symbols (); gfc_clear_warning (); @@ -1867,13 +1891,12 @@ parse_derived_contains (void) case ST_DATA_DECL: gfc_error ("Components in TYPE at %C must precede CONTAINS"); - error_flag = true; - break; + goto error; case ST_PROCEDURE: if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Type-bound" " procedure at %C") == FAILURE) - error_flag = true; + goto error; accept_statement (ST_PROCEDURE); seen_comps = true; @@ -1882,7 +1905,7 @@ parse_derived_contains (void) case ST_GENERIC: if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: GENERIC binding" " at %C") == FAILURE) - error_flag = true; + goto error; accept_statement (ST_GENERIC); seen_comps = true; @@ -1892,7 +1915,7 @@ parse_derived_contains (void) if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FINAL procedure declaration" " at %C") == FAILURE) - error_flag = true; + goto error; accept_statement (ST_FINAL); seen_comps = true; @@ -1905,7 +1928,7 @@ parse_derived_contains (void) && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type " "definition at %C with empty CONTAINS " "section") == FAILURE)) - error_flag = true; + goto error; /* ST_END_TYPE is accepted by parse_derived after return. */ break; @@ -1915,22 +1938,20 @@ parse_derived_contains (void) { gfc_error ("PRIVATE statement in TYPE at %C must be inside " "a MODULE"); - error_flag = true; - break; + goto error; } if (seen_comps) { gfc_error ("PRIVATE statement at %C must precede procedure" " bindings"); - error_flag = true; - break; + goto error; } if (seen_private) { gfc_error ("Duplicate PRIVATE statement at %C"); - error_flag = true; + goto error; } accept_statement (ST_PRIVATE); @@ -1940,18 +1961,22 @@ parse_derived_contains (void) case ST_SEQUENCE: gfc_error ("SEQUENCE statement at %C must precede CONTAINS"); - error_flag = true; - break; + goto error; case ST_CONTAINS: gfc_error ("Already inside a CONTAINS block at %C"); - error_flag = true; - break; + goto error; default: unexpected_statement (st); break; } + + continue; + +error: + error_flag = true; + reject_statement (); } pop_state (); @@ -1966,14 +1991,12 @@ parse_derived_contains (void) static void parse_derived (void) { - int compiling_type, seen_private, seen_sequence, seen_component, error_flag; + int compiling_type, seen_private, seen_sequence, seen_component; gfc_statement st; gfc_state_data s; gfc_symbol *sym; gfc_component *c; - error_flag = 0; - accept_statement (ST_DERIVED_DECL); push_state (&s, COMP_DERIVED, gfc_new_block); @@ -2000,18 +2023,15 @@ parse_derived (void) case ST_FINAL: gfc_error ("FINAL declaration at %C must be inside CONTAINS"); - error_flag = 1; break; case ST_END_TYPE: endType: compiling_type = 0; - if (!seen_component - && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type " - "definition at %C without components") - == FAILURE)) - error_flag = 1; + if (!seen_component) + gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type " + "definition at %C without components"); accept_statement (ST_END_TYPE); break; @@ -2021,7 +2041,6 @@ endType: { gfc_error ("PRIVATE statement in TYPE at %C must be inside " "a MODULE"); - error_flag = 1; break; } @@ -2029,15 +2048,11 @@ endType: { gfc_error ("PRIVATE statement at %C must precede " "structure components"); - error_flag = 1; break; } if (seen_private) - { - gfc_error ("Duplicate PRIVATE statement at %C"); - error_flag = 1; - } + gfc_error ("Duplicate PRIVATE statement at %C"); s.sym->component_access = ACCESS_PRIVATE; @@ -2050,7 +2065,6 @@ endType: { gfc_error ("SEQUENCE statement at %C must precede " "structure components"); - error_flag = 1; break; } @@ -2061,7 +2075,6 @@ endType: if (seen_sequence) { gfc_error ("Duplicate SEQUENCE statement at %C"); - error_flag = 1; } seen_sequence = 1; @@ -2070,14 +2083,12 @@ endType: break; case ST_CONTAINS: - if (gfc_notify_std (GFC_STD_F2003, - "Fortran 2003: CONTAINS block in derived type" - " definition at %C") == FAILURE) - error_flag = 1; + gfc_notify_std (GFC_STD_F2003, + "Fortran 2003: CONTAINS block in derived type" + " definition at %C"); accept_statement (ST_CONTAINS); - if (parse_derived_contains ()) - error_flag = 1; + parse_derived_contains (); goto endType; default: @@ -2094,15 +2105,13 @@ endType: { /* Look for allocatable components. */ if (c->attr.allocatable - || (c->ts.type == BT_CLASS - && c->ts.u.derived->components->attr.allocatable) + || (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp)) sym->attr.alloc_comp = 1; /* Look for pointer components. */ if (c->attr.pointer - || (c->ts.type == BT_CLASS - && c->ts.u.derived->components->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; @@ -2112,6 +2121,11 @@ endType: && c->ts.u.derived->attr.proc_pointer_comp)) sym->attr.proc_pointer_comp = 1; + /* Looking for coarray components. */ + if (c->attr.codimension + || (c->attr.coarray_comp && !c->attr.pointer && !c->attr.allocatable)) + sym->attr.coarray_comp = 1; + /* Look for private components. */ if (sym->component_access == ACCESS_PRIVATE || c->attr.access == ACCESS_PRIVATE @@ -2131,14 +2145,11 @@ endType: static void parse_enum (void) { - int error_flag; gfc_statement st; int compiling_enum; gfc_state_data s; int seen_enumerator = 0; - error_flag = 0; - push_state (&s, COMP_ENUM, gfc_new_block); compiling_enum = 1; @@ -2160,10 +2171,7 @@ parse_enum (void) case ST_END_ENUM: compiling_enum = 0; if (!seen_enumerator) - { - gfc_error ("ENUM declaration at %C has no ENUMERATORS"); - error_flag = 1; - } + gfc_error ("ENUM declaration at %C has no ENUMERATORS"); accept_statement (st); break; @@ -2261,9 +2269,9 @@ loop: { if (current_state == COMP_NONE) { - if (new_state == COMP_FUNCTION) + if (new_state == COMP_FUNCTION && sym) gfc_add_function (&sym->attr, sym->name, NULL); - else if (new_state == COMP_SUBROUTINE) + else if (new_state == COMP_SUBROUTINE && sym) gfc_add_subroutine (&sym->attr, sym->name, NULL); current_state = new_state; @@ -2387,7 +2395,10 @@ match_deferred_characteristics (gfc_typespec * ts) gfc_commit_symbols (); } else - gfc_error_check (); + { + gfc_error_check (); + gfc_undo_symbols (); + } gfc_current_locus =loc; return m; @@ -2459,6 +2470,7 @@ loop: case ST_STATEMENT_FUNCTION: gfc_error ("%s statement is not allowed inside of BLOCK at %C", gfc_ascii_statement (st)); + reject_statement (); break; default: @@ -2545,6 +2557,7 @@ declSt: { gfc_error ("%s statement must appear in a MODULE", gfc_ascii_statement (st)); + reject_statement (); break; } @@ -2552,6 +2565,7 @@ declSt: { gfc_error ("%s statement at %C follows another accessibility " "specification", gfc_ascii_statement (st)); + reject_statement (); break; } @@ -3175,7 +3189,8 @@ parse_block_construct (void) my_ns = gfc_build_block_ns (gfc_current_ns); new_st.op = EXEC_BLOCK; - new_st.ext.ns = my_ns; + new_st.ext.block.ns = my_ns; + new_st.ext.block.assoc = NULL; accept_statement (ST_BLOCK); push_state (&s, COMP_BLOCK, my_ns->proc_name); @@ -3188,6 +3203,67 @@ parse_block_construct (void) } +/* Parse an ASSOCIATE construct. This is essentially a BLOCK construct + behind the scenes with compiler-generated variables. */ + +static void +parse_associate (void) +{ + gfc_namespace* my_ns; + gfc_state_data s; + gfc_statement st; + gfc_association_list* a; + + gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASSOCIATE construct at %C"); + + my_ns = gfc_build_block_ns (gfc_current_ns); + + new_st.op = EXEC_BLOCK; + new_st.ext.block.ns = my_ns; + gcc_assert (new_st.ext.block.assoc); + + /* Add all associate-names as BLOCK variables. Creating them is enough + for now, they'll get their values during trans-* phase. */ + gfc_current_ns = my_ns; + for (a = new_st.ext.block.assoc; a; a = a->next) + { + gfc_symbol* sym; + + if (gfc_get_sym_tree (a->name, NULL, &a->st, false)) + gcc_unreachable (); + + sym = a->st->n.sym; + sym->attr.flavor = FL_VARIABLE; + sym->assoc = a; + sym->declared_at = a->where; + gfc_set_sym_referenced (sym); + } + + accept_statement (ST_ASSOCIATE); + push_state (&s, COMP_ASSOCIATE, my_ns->proc_name); + +loop: + st = parse_executable (ST_NONE); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case_end: + accept_statement (st); + my_ns->code = gfc_state_stack->head; + break; + + default: + unexpected_statement (st); + goto loop; + } + + gfc_current_ns = gfc_current_ns->parent; + pop_state (); +} + + /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are handled inside of parse_executable(), because they aren't really loop statements. */ @@ -3557,8 +3633,6 @@ parse_executable (gfc_statement st) case ST_END_SUBROUTINE: case ST_DO: - case ST_CRITICAL: - case ST_BLOCK: case ST_FORALL: case ST_WHERE: case ST_SELECT_CASE: @@ -3588,6 +3662,10 @@ parse_executable (gfc_statement st) parse_block_construct (); break; + case ST_ASSOCIATE: + parse_associate (); + break; + case ST_IF_BLOCK: parse_if_block (); break; @@ -3682,6 +3760,7 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) || (old_sym->ts.type != BT_UNKNOWN && !old_sym->attr.implicit_type) || old_sym->attr.flavor == FL_PARAMETER + || old_sym->attr.use_assoc || old_sym->attr.in_common || old_sym->attr.in_equivalence || old_sym->attr.data @@ -3698,10 +3777,7 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) st->n.sym = sym; sym->refs++; - /* Free the old (local) symbol. */ - old_sym->refs--; - if (old_sym->refs == 0) - gfc_free_symbol (old_sym); + gfc_release_symbol (old_sym); } fixup_contained: @@ -3909,6 +3985,7 @@ contains: { gfc_error ("CONTAINS statement at %C is already in a contained " "program unit"); + reject_statement (); st = next_statement (); goto loop; } @@ -4324,7 +4401,11 @@ prog_units: later and all their interfaces resolved. */ gfc_current_ns->code = s.head; if (next) - next->sibling = gfc_current_ns; + { + for (; next->sibling; next = next->sibling) + ; + next->sibling = gfc_current_ns; + } else gfc_global_ns_list = gfc_current_ns; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 649e54dac82..b18056c1cd7 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -23,14 +23,12 @@ along with GCC; see the file COPYING3. If not see #ifndef GFC_PARSE_H #define GFC_PARSE_H -#include "gfortran.h" - /* Enum for what the compiler is currently doing. */ typedef enum { COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBROUTINE, COMP_FUNCTION, COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS, - COMP_BLOCK, COMP_IF, + COMP_BLOCK, COMP_ASSOCIATE, COMP_IF, COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM, COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL } @@ -44,6 +42,7 @@ typedef struct gfc_state_data gfc_symbol *sym; /* Block name associated with this level */ gfc_symtree *do_variable; /* For DO blocks the iterator variable. */ + struct gfc_code *construct; struct gfc_code *head, *tail; struct gfc_state_data *previous; @@ -70,5 +69,4 @@ match gfc_match_enumerator_def (void); void gfc_free_enum_history (void); extern bool gfc_matching_function; match gfc_match_prefix (gfc_typespec *); -gfc_namespace* gfc_build_block_ns (gfc_namespace *); #endif /* GFC_PARSE_H */ diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 113729fb059..b07632d951c 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1,5 +1,5 @@ /* Primary expression subroutines - Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008 + Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -26,7 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "arith.h" #include "match.h" #include "parse.h" -#include "toplev.h" +#include "constructor.h" /* Matches a kind-parameter expression, which is either a named symbolic constant or a nonnegative integer constant. If @@ -242,7 +242,7 @@ match_hollerith_constant (gfc_expr **result) locus old_loc; gfc_expr *e = NULL; const char *msg; - int num; + int num, pad; int i; old_loc = gfc_current_locus; @@ -276,10 +276,13 @@ match_hollerith_constant (gfc_expr **result) else { gfc_free_expr (e); - e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind, - &gfc_current_locus); + e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind, + &gfc_current_locus); - e->representation.string = XCNEWVEC (char, num + 1); + /* Calculate padding needed to fit default integer memory. */ + pad = gfc_default_integer_kind - (num % gfc_default_integer_kind); + + e->representation.string = XCNEWVEC (char, num + pad + 1); for (i = 0; i < num; i++) { @@ -294,8 +297,13 @@ match_hollerith_constant (gfc_expr **result) e->representation.string[i] = (unsigned char) c; } - e->representation.string[num] = '\0'; - e->representation.length = num; + /* Now pad with blanks and end with a null char. */ + for (i = 0; i < pad; i++) + e->representation.string[num + i] = ' '; + + e->representation.string[num + i] = '\0'; + e->representation.length = num + pad; + e->ts.u.pad = pad; *result = e; return MATCH_YES; @@ -711,7 +719,7 @@ match_substring (gfc_charlen *cl, int init, gfc_ref **result) ref->type = REF_SUBSTRING; if (start == NULL) - start = gfc_int_expr (1); + start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); ref->u.ss.start = start; if (end == NULL && cl) end = gfc_copy_expr (cl->length); @@ -867,12 +875,11 @@ match_string_constant (gfc_expr **result) gfc_gobble_whitespace (); - start_locus = gfc_current_locus; - c = gfc_next_char (); if (c == '\'' || c == '"') { kind = gfc_default_character_kind; + start_locus = gfc_current_locus; goto got_delim; } @@ -916,12 +923,13 @@ match_string_constant (gfc_expr **result) goto no_match; gfc_gobble_whitespace (); - start_locus = gfc_current_locus; c = gfc_next_char (); if (c != '\'' && c != '"') goto no_match; + start_locus = gfc_current_locus; + if (kind == -1) { q = gfc_extract_int (sym->value, &kind); @@ -969,28 +977,19 @@ got_delim: if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x') goto no_match; - - e = gfc_get_expr (); - - e->expr_type = EXPR_CONSTANT; + e = gfc_get_character_expr (kind, &start_locus, NULL, length); e->ref = NULL; - e->ts.type = BT_CHARACTER; - e->ts.kind = kind; e->ts.is_c_interop = 0; e->ts.is_iso_c = 0; - e->where = start_locus; - - e->value.character.string = p = gfc_get_wide_string (length + 1); - e->value.character.length = length; gfc_current_locus = start_locus; - gfc_next_char (); /* Skip delimiter */ /* We disable the warning for the following loop as the warning has already been printed in the loop above. */ warn_ampersand = gfc_option.warn_ampersand; gfc_option.warn_ampersand = 0; + p = e->value.character.string; for (i = 0; i < length; i++) { c = next_string_char (delimiter, &ret); @@ -1084,15 +1083,9 @@ match_logical_constant (gfc_expr **result) return MATCH_ERROR; } - e = gfc_get_expr (); - - e->expr_type = EXPR_CONSTANT; - e->value.logical = i; - e->ts.type = BT_LOGICAL; - e->ts.kind = kind; + e = gfc_get_logical_expr (kind, &gfc_current_locus, i); e->ts.is_c_interop = 0; e->ts.is_iso_c = 0; - e->where = gfc_current_locus; *result = e; return MATCH_YES; @@ -1746,13 +1739,37 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, tail = NULL; gfc_gobble_whitespace (); + + if (gfc_peek_ascii_char () == '[') + { + if (sym->attr.dimension) + { + gfc_error ("Array section designator, e.g. '(:)', is required " + "besides the coarray designator '[...]' at %C"); + return MATCH_ERROR; + } + if (!sym->attr.codimension) + { + gfc_error ("Coarray designator at %C but '%s' is not a coarray", + sym->name); + return MATCH_ERROR; + } + } + + /* For associate names, we may not yet know whether they are arrays or not. + Thus if we have one and parentheses follow, we have to assume that it + actually is one for now. The final decision will be made at + resolution time, of course. */ + if (sym->assoc && gfc_peek_ascii_char () == '(') + sym->attr.dimension = 1; + if ((equiv_flag && gfc_peek_ascii_char () == '(') + || gfc_peek_ascii_char () == '[' || sym->attr.codimension || (sym->attr.dimension && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary, NULL) && !(gfc_matching_procptr_assignment && sym->attr.flavor == FL_PROCEDURE)) - || (sym->ts.type == BT_CLASS - && sym->ts.u.derived->components->attr.dimension)) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)) { /* In EQUIVALENCE, we don't know yet whether we are seeing an array, character variable or array of character @@ -1761,7 +1778,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, tail->type = REF_ARRAY; m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as, - equiv_flag); + equiv_flag, sym->as ? sym->as->corank : 0); if (m != MATCH_YES) return m; @@ -1771,7 +1788,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, tail = extend_ref (primary, tail); tail->type = REF_ARRAY; - m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag); + m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0); if (m != MATCH_YES) return m; } @@ -1881,20 +1898,21 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, tail = extend_ref (primary, tail); tail->type = REF_ARRAY; - m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag); + m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag, + component->as->corank); if (m != MATCH_YES) return m; } else if (component->ts.type == BT_CLASS - && component->ts.u.derived->components->as != NULL + && CLASS_DATA (component)->as != NULL && !component->attr.proc_pointer) { tail = extend_ref (primary, tail); tail->type = REF_ARRAY; - m = gfc_match_array_ref (&tail->u.ar, - component->ts.u.derived->components->as, - equiv_flag); + m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as, + equiv_flag, + CLASS_DATA (component)->as->corank); if (m != MATCH_YES) return m; } @@ -1949,6 +1967,13 @@ check_substring: } } + /* F2008, C727. */ + if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary)) + { + gfc_error ("Coindexed procedure-pointer component at %C"); + return MATCH_ERROR; + } + return MATCH_YES; } @@ -1988,9 +2013,9 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) if (sym->ts.type == BT_CLASS) { - dimension = sym->ts.u.derived->components->attr.dimension; - pointer = sym->ts.u.derived->components->attr.pointer; - allocatable = sym->ts.u.derived->components->attr.allocatable; + dimension = CLASS_DATA (sym)->attr.dimension; + pointer = CLASS_DATA (sym)->attr.class_pointer; + allocatable = CLASS_DATA (sym)->attr.allocatable; } else { @@ -2023,7 +2048,9 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) break; case AR_ELEMENT: - allocatable = pointer = 0; + /* Handle coarrays. */ + if (ref->u.ar.dimen > 0) + allocatable = pointer = 0; break; case AR_UNKNOWN: @@ -2047,8 +2074,8 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) if (comp->ts.type == BT_CLASS) { - pointer = comp->ts.u.derived->components->attr.pointer; - allocatable = comp->ts.u.derived->components->attr.allocatable; + pointer = CLASS_DATA (comp)->attr.class_pointer; + allocatable = CLASS_DATA (comp)->attr.allocatable; } else { @@ -2069,6 +2096,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) attr.pointer = pointer; attr.allocatable = allocatable; attr.target = target; + attr.save = sym->attr.save; return attr; } @@ -2096,9 +2124,9 @@ gfc_expr_attr (gfc_expr *e) attr = sym->attr; if (sym->ts.type == BT_CLASS) { - attr.dimension = sym->ts.u.derived->components->attr.dimension; - attr.pointer = sym->ts.u.derived->components->attr.pointer; - attr.allocatable = sym->ts.u.derived->components->attr.allocatable; + attr.dimension = CLASS_DATA (sym)->attr.dimension; + attr.pointer = CLASS_DATA (sym)->attr.class_pointer; + attr.allocatable = CLASS_DATA (sym)->attr.allocatable; } } else @@ -2146,10 +2174,9 @@ gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp) for components without explicit value given. */ static gfc_try build_actual_constructor (gfc_structure_ctor_component **comp_head, - gfc_constructor **ctor_head, gfc_symbol *sym) + gfc_constructor_base *ctor_head, gfc_symbol *sym) { gfc_structure_ctor_component *comp_iter; - gfc_constructor *ctor_tail = NULL; gfc_component *comp; for (comp = sym->components; comp; comp = comp->next) @@ -2170,11 +2197,10 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head, a value expression for the parent derived type and calling self. */ if (!comp_iter && comp == sym->components && sym->attr.extension) { - value = gfc_get_expr (); - value->expr_type = EXPR_STRUCTURE; - value->value.constructor = NULL; + value = gfc_get_structure_constructor_expr (comp->ts.type, + comp->ts.kind, + &gfc_current_locus); value->ts = comp->ts; - value->where = gfc_current_locus; if (build_actual_constructor (comp_head, &value->value.constructor, comp->ts.u.derived) == FAILURE) @@ -2182,8 +2208,8 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head, gfc_free_expr (value); return FAILURE; } - *ctor_head = ctor_tail = gfc_get_constructor (); - ctor_tail->expr = value; + + gfc_constructor_append_expr (ctor_head, value, NULL); continue; } @@ -2210,15 +2236,7 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head, value = comp_iter->val; /* Add the value to the constructor chain built. */ - if (ctor_tail) - { - ctor_tail->next = gfc_get_constructor (); - ctor_tail = ctor_tail->next; - } - else - *ctor_head = ctor_tail = gfc_get_constructor (); - gcc_assert (value); - ctor_tail->expr = value; + gfc_constructor_append_expr (ctor_head, value, NULL); /* Remove the entry from the component list. We don't want the expression value to be free'd, so set it to NULL. */ @@ -2237,7 +2255,7 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, bool parent) { gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter; - gfc_constructor *ctor_head, *ctor_tail; + gfc_constructor_base ctor_head = NULL; gfc_component *comp; /* Is set NULL when named component is first seen */ gfc_expr *e; locus where; @@ -2245,7 +2263,6 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, const char* last_name = NULL; comp_tail = comp_head = NULL; - ctor_head = ctor_tail = NULL; if (!parent && gfc_match_char ('(') != MATCH_YES) goto syntax; @@ -2349,6 +2366,15 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, if (m == MATCH_ERROR) goto cleanup; + /* F2008, R457/C725, for PURE C1283. */ + if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val)) + { + gfc_error ("Coindexed expression to pointer component '%s' in " + "structure constructor at %C!", comp_tail->name); + goto cleanup; + } + + /* If not explicitly a parent constructor, gather up the components and build one. */ if (comp && comp == sym->components @@ -2401,14 +2427,8 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, else gcc_assert (!comp_head); - e = gfc_get_expr (); - - e->expr_type = EXPR_STRUCTURE; - - e->ts.type = BT_DERIVED; + e = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &where); e->ts.u.derived = sym; - e->where = where; - e->value.constructor = ctor_head; *result = e; @@ -2424,7 +2444,7 @@ cleanup: gfc_free_structure_ctor_component (comp_iter); comp_iter = next; } - gfc_free_constructor (ctor_head); + gfc_constructor_free (ctor_head); return MATCH_ERROR; } @@ -2971,6 +2991,8 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag) gfc_error ("Assigning to PROTECTED variable at %C"); return MATCH_ERROR; } + if (sym->assoc) + sym->assoc->variable = 1; break; case FL_UNKNOWN: diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8ef347d1ac8..2d5e04f22d5 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -29,6 +29,7 @@ along with GCC; see the file COPYING3. If not see #include "dependency.h" #include "data.h" #include "target-memory.h" /* for gfc_simplify_transfer */ +#include "constructor.h" /* Types used in equivalence statements. */ @@ -77,6 +78,9 @@ static int current_entry_id; /* We use bitmaps to determine if a branch target is valid. */ static bitmap_obstack labels_obstack; +/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */ +static bool inquiry_argument = false; + int gfc_is_formal_arg (void) { @@ -122,6 +126,88 @@ resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name) } +static void resolve_symbol (gfc_symbol *sym); +static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc); + + +/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */ + +static gfc_try +resolve_procedure_interface (gfc_symbol *sym) +{ + if (sym->ts.interface == sym) + { + gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface", + sym->name, &sym->declared_at); + return FAILURE; + } + if (sym->ts.interface->attr.procedure) + { + gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared " + "in a later PROCEDURE statement", sym->ts.interface->name, + sym->name, &sym->declared_at); + return FAILURE; + } + + /* Get the attributes from the interface (now resolved). */ + if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic) + { + gfc_symbol *ifc = sym->ts.interface; + resolve_symbol (ifc); + + if (ifc->attr.intrinsic) + resolve_intrinsic (ifc, &ifc->declared_at); + + if (ifc->result) + sym->ts = ifc->result->ts; + else + sym->ts = ifc->ts; + sym->ts.interface = ifc; + sym->attr.function = ifc->attr.function; + sym->attr.subroutine = ifc->attr.subroutine; + gfc_copy_formal_args (sym, ifc); + + sym->attr.allocatable = ifc->attr.allocatable; + sym->attr.pointer = ifc->attr.pointer; + sym->attr.pure = ifc->attr.pure; + sym->attr.elemental = ifc->attr.elemental; + sym->attr.dimension = ifc->attr.dimension; + sym->attr.contiguous = ifc->attr.contiguous; + sym->attr.recursive = ifc->attr.recursive; + sym->attr.always_explicit = ifc->attr.always_explicit; + sym->attr.ext_attr |= ifc->attr.ext_attr; + /* Copy array spec. */ + sym->as = gfc_copy_array_spec (ifc->as); + if (sym->as) + { + int i; + for (i = 0; i < sym->as->rank; i++) + { + gfc_expr_replace_symbols (sym->as->lower[i], sym); + gfc_expr_replace_symbols (sym->as->upper[i], sym); + } + } + /* Copy char length. */ + if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) + { + sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); + gfc_expr_replace_symbols (sym->ts.u.cl->length, sym); + if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved + && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE) + return FAILURE; + } + } + else if (sym->ts.interface->name[0] != '\0') + { + gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit", + sym->ts.interface->name, sym->name, &sym->declared_at); + return FAILURE; + } + + return SUCCESS; +} + + /* Resolve types of formal argument lists. These have to be done early so that the formal argument lists of module procedures can be copied to the containing module before the individual procedures are resolved @@ -170,6 +256,9 @@ resolve_formal_arglist (gfc_symbol *proc) &proc->declared_at); continue; } + else if (sym->attr.procedure && sym->ts.interface + && sym->attr.if_source != IFSRC_DECL) + resolve_procedure_interface (sym); if (sym->attr.if_source != IFSRC_UNKNOWN) resolve_formal_arglist (sym); @@ -224,7 +313,8 @@ resolve_formal_arglist (gfc_symbol *proc) { sym->as->type = AS_ASSUMED_SHAPE; for (i = 0; i < sym->as->rank; i++) - sym->as->lower[i] = gfc_int_expr (1); + sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1); } if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE) @@ -258,6 +348,14 @@ resolve_formal_arglist (gfc_symbol *proc) if (gfc_elemental (proc)) { + /* F2008, C1289. */ + if (sym->attr.codimension) + { + gfc_error ("Coarray dummy argument '%s' at %L to elemental " + "procedure", sym->name, &sym->declared_at); + continue; + } + if (sym->as != NULL) { gfc_error ("Argument '%s' of elemental procedure at %L must " @@ -265,6 +363,14 @@ resolve_formal_arglist (gfc_symbol *proc) continue; } + if (sym->attr.allocatable) + { + gfc_error ("Argument '%s' of elemental procedure at %L cannot " + "have the ALLOCATABLE attribute", sym->name, + &sym->declared_at); + continue; + } + if (sym->attr.pointer) { gfc_error ("Argument '%s' of elemental procedure at %L cannot " @@ -280,6 +386,14 @@ resolve_formal_arglist (gfc_symbol *proc) &sym->declared_at); continue; } + + if (sym->attr.intent == INTENT_UNKNOWN) + { + gfc_error ("Argument '%s' of elemental procedure '%s' at %L must " + "have its INTENT specified", sym->name, proc->name, + &sym->declared_at); + continue; + } } /* Each dummy shall be specified to be scalar. */ @@ -690,21 +804,6 @@ resolve_entries (gfc_namespace *ns) } -static bool -has_default_initializer (gfc_symbol *der) -{ - gfc_component *c; - - gcc_assert (der->attr.flavor == FL_DERIVED); - for (c = der->components; c; c = c->next) - if ((c->ts.type != BT_DERIVED && c->initializer) - || (c->ts.type == BT_DERIVED - && (!c->attr.pointer && has_default_initializer (c->ts.u.derived)))) - break; - - return c != NULL; -} - /* Resolve common variables. */ static void resolve_common_vars (gfc_symbol *sym, bool named_common) @@ -738,7 +837,7 @@ resolve_common_vars (gfc_symbol *sym, bool named_common) gfc_error_now ("Derived type variable '%s' in COMMON at %L " "has an ultimate component that is " "allocatable", csym->name, &csym->declared_at); - if (has_default_initializer (csym->ts.u.derived)) + if (gfc_has_default_initializer (csym->ts.u.derived)) gfc_error_now ("Derived type variable '%s' in COMMON at %L " "may not have default initializer", csym->name, &csym->declared_at); @@ -819,10 +918,11 @@ resolve_contained_functions (gfc_namespace *ns) /* Resolve all of the elements of a structure constructor and make sure that - the types are correct. */ + the types are correct. The 'init' flag indicates that the given + constructor is an initializer. */ static gfc_try -resolve_structure_cons (gfc_expr *expr) +resolve_structure_cons (gfc_expr *expr, int init) { gfc_constructor *cons; gfc_component *comp; @@ -830,7 +930,11 @@ resolve_structure_cons (gfc_expr *expr) symbol_attribute a; t = SUCCESS; - cons = expr->value.constructor; + + if (expr->ts.type == BT_DERIVED) + resolve_symbol (expr->ts.u.derived); + + cons = gfc_constructor_first (expr->value.constructor); /* A constructor may have references if it is the result of substituting a parameter variable. In this case we just pull out the component we want. */ @@ -856,7 +960,7 @@ resolve_structure_cons (gfc_expr *expr) && cons->expr && cons->expr->expr_type == EXPR_NULL) return SUCCESS; - for (; comp; comp = comp->next, cons = cons->next) + for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) { int rank; @@ -882,10 +986,19 @@ resolve_structure_cons (gfc_expr *expr) /* If we don't have the right type, try to convert it. */ - if (!gfc_compare_types (&cons->expr->ts, &comp->ts)) + if (!comp->attr.proc_pointer && + !gfc_compare_types (&cons->expr->ts, &comp->ts)) { t = FAILURE; - if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN) + if (strcmp (comp->name, "$extends") == 0) + { + /* Can afford to be brutal with the $extends initializer. + The derived type can get lost because it is PRIVATE + but it is not usage constrained by the standard. */ + cons->expr->ts = comp->ts; + t = SUCCESS; + } + else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN) gfc_error ("The element in the derived type constructor at %L, " "for pointer component '%s', is %s but should be %s", &cons->expr->where, comp->name, @@ -895,12 +1008,73 @@ resolve_structure_cons (gfc_expr *expr) t = gfc_convert_type (cons->expr, &comp->ts, 1); } + /* For strings, the length of the constructor should be the same as + the one of the structure, ensure this if the lengths are known at + compile time and when we are dealing with PARAMETER or structure + constructors. */ + if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl + && comp->ts.u.cl->length + && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT + && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length + && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT + && mpz_cmp (cons->expr->ts.u.cl->length->value.integer, + comp->ts.u.cl->length->value.integer) != 0) + { + if (cons->expr->expr_type == EXPR_VARIABLE + && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER) + { + /* Wrap the parameter in an array constructor (EXPR_ARRAY) + to make use of the gfc_resolve_character_array_constructor + machinery. The expression is later simplified away to + an array of string literals. */ + gfc_expr *para = cons->expr; + cons->expr = gfc_get_expr (); + cons->expr->ts = para->ts; + cons->expr->where = para->where; + cons->expr->expr_type = EXPR_ARRAY; + cons->expr->rank = para->rank; + cons->expr->shape = gfc_copy_shape (para->shape, para->rank); + gfc_constructor_append_expr (&cons->expr->value.constructor, + para, &cons->expr->where); + } + if (cons->expr->expr_type == EXPR_ARRAY) + { + gfc_constructor *p; + p = gfc_constructor_first (cons->expr->value.constructor); + if (cons->expr->ts.u.cl != p->expr->ts.u.cl) + { + gfc_charlen *cl, *cl2; + + cl2 = NULL; + for (cl = gfc_current_ns->cl_list; cl; cl = cl->next) + { + if (cl == cons->expr->ts.u.cl) + break; + cl2 = cl; + } + + gcc_assert (cl); + + if (cl2) + cl2->next = cl->next; + + gfc_free_expr (cl->length); + gfc_free (cl); + } + + cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + cons->expr->ts.u.cl->length_from_typespec = true; + cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length); + gfc_resolve_character_array_constructor (cons->expr); + } + } + if (cons->expr->expr_type == EXPR_NULL && !(comp->attr.pointer || comp->attr.allocatable || comp->attr.proc_pointer || (comp->ts.type == BT_CLASS - && (comp->ts.u.derived->components->attr.pointer - || comp->ts.u.derived->components->attr.allocatable)))) + && (CLASS_DATA (comp)->attr.class_pointer + || CLASS_DATA (comp)->attr.allocatable)))) { t = FAILURE; gfc_error ("The NULL in the derived type constructor at %L is " @@ -909,7 +1083,8 @@ resolve_structure_cons (gfc_expr *expr) comp->name); } - if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL) + if (!comp->attr.pointer || comp->attr.proc_pointer + || cons->expr->expr_type == EXPR_NULL) continue; a = gfc_expr_attr (cons->expr); @@ -922,15 +1097,34 @@ resolve_structure_cons (gfc_expr *expr) "a TARGET", &cons->expr->where, comp->name); } + if (init) + { + /* F08:C461. Additional checks for pointer initialization. */ + if (a.allocatable) + { + t = FAILURE; + gfc_error ("Pointer initialization target at %L " + "must not be ALLOCATABLE ", &cons->expr->where); + } + if (!a.save) + { + t = FAILURE; + gfc_error ("Pointer initialization target at %L " + "must have the SAVE attribute", &cons->expr->where); + } + } + /* F2003, C1272 (3). */ if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE - && gfc_impure_variable (cons->expr->symtree->n.sym)) + && (gfc_impure_variable (cons->expr->symtree->n.sym) + || gfc_is_coindexed (cons->expr))) { t = FAILURE; - gfc_error ("Invalid expression in the derived type constructor for pointer " - "component '%s' at %L in PURE procedure", comp->name, - &cons->expr->where); + gfc_error ("Invalid expression in the derived type constructor for " + "pointer component '%s' at %L in PURE procedure", + comp->name, &cons->expr->where); } + } return t; @@ -955,7 +1149,7 @@ was_declared (gfc_symbol *sym) if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic || a.optional || a.pointer || a.save || a.target || a.volatile_ || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN - || a.asynchronous) + || a.asynchronous || a.codimension) return 1; return 0; @@ -1311,7 +1505,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, gfc_expr *e; int save_need_full_assumed_size; gfc_component *comp; - + for (; arg; arg = arg->next) { e = arg->expr; @@ -1396,8 +1590,11 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, if (sym->attr.contained && !sym->attr.use_assoc && sym->ns->proc_name->attr.flavor != FL_MODULE) { - gfc_error ("Internal procedure '%s' is not allowed as an " - "actual argument at %L", sym->name, &e->where); + if (gfc_notify_std (GFC_STD_F2008, + "Fortran 2008: Internal procedure '%s' is" + " used as actual argument at %L", + sym->name, &e->where) == FAILURE) + return FAILURE; } if (sym->attr.elemental && !sym->attr.intrinsic) @@ -1541,6 +1738,15 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, } } } + + /* Fortran 2008, C1237. */ + if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e) + && gfc_has_ultimate_pointer (e)) + { + gfc_error ("Coindexed actual argument at %L with ultimate pointer " + "component", &e->where); + return FAILURE; + } } return SUCCESS; @@ -1710,25 +1916,6 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) } -/* Go through each actual argument in ACTUAL and see if it can be - implemented as an inlined, non-copying intrinsic. FNSYM is the - function being called, or NULL if not known. */ - -static void -find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual) -{ - gfc_actual_arglist *ap; - gfc_expr *expr; - - for (ap = actual; ap; ap = ap->next) - if (ap->expr - && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr)) - && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual, - NOT_ELEMENTAL)) - ap->expr->inline_noncopying_intrinsic = 1; -} - - /* This function does the checking of references to global procedures as defined in sections 18.1 and 14.1, respectively, of the Fortran 77 and 95 standards. It checks for a gsymbol for the name, making @@ -1800,7 +1987,8 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, gfc_global_used (gsym, where); if (gfc_option.flag_whole_file - && sym->attr.if_source == IFSRC_UNKNOWN + && (sym->attr.if_source == IFSRC_UNKNOWN + || sym->attr.if_source == IFSRC_IFBODY) && gsym->type != GSYM_UNKNOWN && gsym->ns && gsym->ns->resolved != -1 @@ -1808,20 +1996,9 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, && not_in_recursive (sym, gsym->ns) && not_entry_self_reference (sym, gsym->ns)) { - /* Make sure that translation for the gsymbol occurs before - the procedure currently being resolved. */ - ns = gsym->ns->resolved ? NULL : gfc_global_ns_list; - for (; ns && ns != gsym->ns; ns = ns->sibling) - { - if (ns->sibling == gsym->ns) - { - ns->sibling = gsym->ns->sibling; - gsym->ns->sibling = gfc_global_ns_list; - gfc_global_ns_list = gsym->ns; - break; - } - } + gfc_symbol *def_sym; + /* Resolve the gsymbol namespace if needed. */ if (!gsym->ns->resolved) { gfc_dt_list *old_dt_list; @@ -1841,37 +2018,177 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, gfc_derived_types = old_dt_list; } - if (gsym->ns->proc_name->attr.function - && gsym->ns->proc_name->as - && gsym->ns->proc_name->as->rank - && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank)) - gfc_error ("The reference to function '%s' at %L either needs an " - "explicit INTERFACE or the rank is incorrect", sym->name, - where); - - /* Non-assumed length character functions. */ - if (sym->attr.function && sym->ts.type == BT_CHARACTER - && gsym->ns->proc_name->ts.u.cl != NULL - && gsym->ns->proc_name->ts.u.cl->length != NULL) + /* Make sure that translation for the gsymbol occurs before + the procedure currently being resolved. */ + ns = gfc_global_ns_list; + for (; ns && ns != gsym->ns; ns = ns->sibling) + { + if (ns->sibling == gsym->ns) + { + ns->sibling = gsym->ns->sibling; + gsym->ns->sibling = gfc_global_ns_list; + gfc_global_ns_list = gsym->ns; + break; + } + } + + def_sym = gsym->ns->proc_name; + if (def_sym->attr.entry_master) + { + gfc_entry_list *entry; + for (entry = gsym->ns->entries; entry; entry = entry->next) + if (strcmp (entry->sym->name, sym->name) == 0) + { + def_sym = entry->sym; + break; + } + } + + /* Differences in constant character lengths. */ + if (sym->attr.function && sym->ts.type == BT_CHARACTER) { - gfc_charlen *cl = sym->ts.u.cl; + long int l1 = 0, l2 = 0; + gfc_charlen *cl1 = sym->ts.u.cl; + gfc_charlen *cl2 = def_sym->ts.u.cl; + + if (cl1 != NULL + && cl1->length != NULL + && cl1->length->expr_type == EXPR_CONSTANT) + l1 = mpz_get_si (cl1->length->value.integer); + + if (cl2 != NULL + && cl2->length != NULL + && cl2->length->expr_type == EXPR_CONSTANT) + l2 = mpz_get_si (cl2->length->value.integer); + + if (l1 && l2 && l1 != l2) + gfc_error ("Character length mismatch in return type of " + "function '%s' at %L (%ld/%ld)", sym->name, + &sym->declared_at, l1, l2); + } + + /* Type mismatch of function return type and expected type. */ + if (sym->attr.function + && !gfc_compare_types (&sym->ts, &def_sym->ts)) + gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)", + sym->name, &sym->declared_at, gfc_typename (&sym->ts), + gfc_typename (&def_sym->ts)); + + if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY) + { + gfc_formal_arglist *arg = def_sym->formal; + for ( ; arg; arg = arg->next) + if (!arg->sym) + continue; + /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */ + else if (arg->sym->attr.allocatable + || arg->sym->attr.asynchronous + || arg->sym->attr.optional + || arg->sym->attr.pointer + || arg->sym->attr.target + || arg->sym->attr.value + || arg->sym->attr.volatile_) + { + gfc_error ("Dummy argument '%s' of procedure '%s' at %L " + "has an attribute that requires an explicit " + "interface for this procedure", arg->sym->name, + sym->name, &sym->declared_at); + break; + } + /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */ + else if (arg->sym && arg->sym->as + && arg->sym->as->type == AS_ASSUMED_SHAPE) + { + gfc_error ("Procedure '%s' at %L with assumed-shape dummy " + "argument '%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } + /* F2008, 12.4.2.2 (2c) */ + else if (arg->sym->attr.codimension) + { + gfc_error ("Procedure '%s' at %L with coarray dummy argument " + "'%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } + /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */ + else if (false) /* TODO: is a parametrized derived type */ + { + gfc_error ("Procedure '%s' at %L with parametrized derived " + "type argument '%s' must have an explicit " + "interface", sym->name, &sym->declared_at, + arg->sym->name); + break; + } + /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */ + else if (arg->sym->ts.type == BT_CLASS) + { + gfc_error ("Procedure '%s' at %L with polymorphic dummy " + "argument '%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } + } - if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN - && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) + if (def_sym->attr.function) + { + /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */ + if (def_sym->as && def_sym->as->rank + && (!sym->as || sym->as->rank != def_sym->as->rank)) + gfc_error ("The reference to function '%s' at %L either needs an " + "explicit INTERFACE or the rank is incorrect", sym->name, + where); + + /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */ + if ((def_sym->result->attr.pointer + || def_sym->result->attr.allocatable) + && (sym->attr.if_source != IFSRC_IFBODY + || def_sym->result->attr.pointer + != sym->result->attr.pointer + || def_sym->result->attr.allocatable + != sym->result->attr.allocatable)) + gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE " + "result must have an explicit interface", sym->name, + where); + + /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */ + if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY + && def_sym->ts.u.cl->length != NULL) { - gfc_error ("Nonconstant character-length function '%s' at %L " - "must have an explicit interface", sym->name, - &sym->declared_at); + gfc_charlen *cl = sym->ts.u.cl; + + if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN + && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) + { + gfc_error ("Nonconstant character-length function '%s' at %L " + "must have an explicit interface", sym->name, + &sym->declared_at); + } } } + /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */ + if (def_sym->attr.elemental && !sym->attr.elemental) + { + gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit " + "interface", sym->name, &sym->declared_at); + } + + /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */ + if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c) + { + gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have " + "an explicit interface", sym->name, &sym->declared_at); + } + if (gfc_option.flag_whole_file == 1 - || ((gfc_option.warn_std & GFC_STD_LEGACY) - && - !(gfc_option.warn_std & GFC_STD_GNU))) + || ((gfc_option.warn_std & GFC_STD_LEGACY) + && !(gfc_option.warn_std & GFC_STD_GNU))) gfc_errors_to_warnings (1); - gfc_procedure_use (gsym->ns->proc_name, actual, where); + if (sym->attr.if_source != IFSRC_IFBODY) + gfc_procedure_use (def_sym, actual, where); gfc_errors_to_warnings (0); } @@ -2133,6 +2450,7 @@ is_external_proc (gfc_symbol *sym) && !(sym->attr.intrinsic || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)) && sym->attr.proc != PROC_ST_FUNCTION + && !sym->attr.proc_pointer && !sym->attr.use_assoc && sym->name) return true; @@ -2313,10 +2631,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 @@ -2333,8 +2652,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) { @@ -2377,7 +2695,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", @@ -2460,7 +2778,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 @@ -2495,6 +2813,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) @@ -2582,11 +2907,19 @@ resolve_function (gfc_expr *expr) if (expr->symtree && expr->symtree->n.sym) p = expr->symtree->n.sym->attr.proc; + if (expr->value.function.isym && expr->value.function.isym->inquiry) + inquiry_argument = true; no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL; + if (resolve_actual_arglist (expr->value.function.actual, p, no_formal_args) == FAILURE) + { + inquiry_argument = false; return FAILURE; + } + inquiry_argument = false; + /* Need to setup the call to the correct c_associated, depending on the number of cptrs to user gives to compare. */ if (sym && sym->attr.is_iso_c == 1) @@ -2763,15 +3096,6 @@ resolve_function (gfc_expr *expr) gfc_expr_set_symbols_referenced (expr->ts.u.cl->length); } - if (t == SUCCESS - && !((expr->value.function.esym - && expr->value.function.esym->attr.elemental) - || - (expr->value.function.isym - && expr->value.function.isym->elemental))) - find_noncopying_intrinsics (expr->value.function.esym, - expr->value.function.actual); - /* Make sure that the expression has a typespec that works. */ if (expr->ts.type == BT_UNKNOWN) { @@ -3250,8 +3574,6 @@ resolve_call (gfc_code *c) if (resolve_elemental_actual (NULL, c) == FAILURE) return FAILURE; - if (t == SUCCESS && !(c->resolved_sym && c->resolved_sym->attr.elemental)) - find_noncopying_intrinsics (c->resolved_sym, c->ext.actual); return t; } @@ -3540,11 +3862,11 @@ resolve_operator (gfc_expr *e) e->rank = op1->rank; if (e->shape == NULL) { - t = compare_shapes(op1, op2); + t = compare_shapes (op1, op2); if (t == FAILURE) e->shape = NULL; else - e->shape = gfc_copy_shape (op1->shape, op1->rank); + e->shape = gfc_copy_shape (op1->shape, op1->rank); } } else @@ -3747,6 +4069,17 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) { mpz_t last_value; + if (ar->dimen_type[i] == DIMEN_STAR) + { + gcc_assert (ar->stride[i] == NULL); + /* This implies [*] as [*:] and [*:3] are not possible. */ + if (ar->start[i] == NULL) + { + gcc_assert (ar->end[i] == NULL); + return SUCCESS; + } + } + /* Given start, end and stride values, calculate the minimum and maximum referenced indexes. */ @@ -3755,21 +4088,36 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) case DIMEN_VECTOR: break; + case DIMEN_STAR: case DIMEN_ELEMENT: if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT) { - gfc_warning ("Array reference at %L is out of bounds " - "(%ld < %ld) in dimension %d", &ar->c_where[i], - mpz_get_si (ar->start[i]->value.integer), - mpz_get_si (as->lower[i]->value.integer), i+1); + if (i < as->rank) + gfc_warning ("Array reference at %L is out of bounds " + "(%ld < %ld) in dimension %d", &ar->c_where[i], + mpz_get_si (ar->start[i]->value.integer), + mpz_get_si (as->lower[i]->value.integer), i+1); + else + gfc_warning ("Array reference at %L is out of bounds " + "(%ld < %ld) in codimension %d", &ar->c_where[i], + mpz_get_si (ar->start[i]->value.integer), + mpz_get_si (as->lower[i]->value.integer), + i + 1 - as->rank); return SUCCESS; } if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT) { - gfc_warning ("Array reference at %L is out of bounds " - "(%ld > %ld) in dimension %d", &ar->c_where[i], - mpz_get_si (ar->start[i]->value.integer), - mpz_get_si (as->upper[i]->value.integer), i+1); + if (i < as->rank) + gfc_warning ("Array reference at %L is out of bounds " + "(%ld > %ld) in dimension %d", &ar->c_where[i], + mpz_get_si (ar->start[i]->value.integer), + mpz_get_si (as->upper[i]->value.integer), i+1); + else + gfc_warning ("Array reference at %L is out of bounds " + "(%ld > %ld) in codimension %d", &ar->c_where[i], + mpz_get_si (ar->start[i]->value.integer), + mpz_get_si (as->upper[i]->value.integer), + i + 1 - as->rank); return SUCCESS; } @@ -3889,18 +4237,41 @@ compare_spec_to_ref (gfc_array_ref *ar) return FAILURE; } + /* ar->codimen == 0 is a local array. */ + if (as->corank != ar->codimen && ar->codimen != 0) + { + gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)", + &ar->where, ar->codimen, as->corank); + return FAILURE; + } + for (i = 0; i < as->rank; i++) if (check_dimension (i, ar, as) == FAILURE) return FAILURE; + /* Local access has no coarray spec. */ + if (ar->codimen != 0) + for (i = as->rank; i < as->rank + as->corank; i++) + { + if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate) + { + gfc_error ("Coindex of codimension %d must be a scalar at %L", + i + 1 - as->rank, &ar->where); + return FAILURE; + } + if (check_dimension (i, ar, as) == FAILURE) + return FAILURE; + } + return SUCCESS; } /* Resolve one part of an array index. */ -gfc_try -gfc_resolve_index (gfc_expr *index, int check_scalar) +static gfc_try +gfc_resolve_index_1 (gfc_expr *index, int check_scalar, + int force_index_integer_kind) { gfc_typespec ts; @@ -3928,7 +4299,8 @@ gfc_resolve_index (gfc_expr *index, int check_scalar) &index->where) == FAILURE) return FAILURE; - if (index->ts.kind != gfc_index_integer_kind + if ((index->ts.kind != gfc_index_integer_kind + && force_index_integer_kind) || index->ts.type != BT_INTEGER) { gfc_clear_ts (&ts); @@ -3941,6 +4313,14 @@ gfc_resolve_index (gfc_expr *index, int check_scalar) return SUCCESS; } +/* Resolve one part of an array index. */ + +gfc_try +gfc_resolve_index (gfc_expr *index, int check_scalar) +{ + return gfc_resolve_index_1 (index, check_scalar, 1); +} + /* Resolve a dim argument to an intrinsic function. */ gfc_try @@ -3998,7 +4378,7 @@ find_array_spec (gfc_expr *e) gfc_ref *ref; if (e->symtree->n.sym->ts.type == BT_CLASS) - as = e->symtree->n.sym->ts.u.derived->components->as; + as = CLASS_DATA (e->symtree->n.sym)->as; else as = e->symtree->n.sym->as; derived = NULL; @@ -4061,11 +4441,14 @@ resolve_array_ref (gfc_array_ref *ar) int i, check_scalar; gfc_expr *e; - for (i = 0; i < ar->dimen; i++) + for (i = 0; i < ar->dimen + ar->codimen; i++) { check_scalar = ar->dimen_type[i] == DIMEN_RANGE; - if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE) + /* Do not force gfc_index_integer_kind for the start. We can + do fine with any integer kind. This avoids temporary arrays + created for indexing with a vector. */ + if (gfc_resolve_index_1 (ar->start[i], check_scalar, 0) == FAILURE) return FAILURE; if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE) return FAILURE; @@ -4093,8 +4476,43 @@ resolve_array_ref (gfc_array_ref *ar) &ar->c_where[i], e->rank); return FAILURE; } + + /* Fill in the upper bound, which may be lower than the + specified one for something like a(2:10:5), which is + identical to a(2:7:5). Only relevant for strides not equal + to one. */ + if (ar->dimen_type[i] == DIMEN_RANGE + && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT + && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0) + { + mpz_t size, end; + + if (gfc_ref_dimen_size (ar, i, &size, &end) == SUCCESS) + { + if (ar->end[i] == NULL) + { + ar->end[i] = + gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, + &ar->where); + mpz_set (ar->end[i]->value.integer, end); + } + else if (ar->end[i]->ts.type == BT_INTEGER + && ar->end[i]->expr_type == EXPR_CONSTANT) + { + mpz_set (ar->end[i]->value.integer, end); + } + else + gcc_unreachable (); + + mpz_clear (size); + mpz_clear (end); + } + } } + if (ar->type == AR_FULL && ar->as->rank == 0) + ar->type = AR_ELEMENT; + /* If the reference type is unknown, figure out what kind it is. */ if (ar->type == AR_UNKNOWN) @@ -4229,7 +4647,7 @@ gfc_resolve_substring_charlen (gfc_expr *e) if (char_ref->u.ss.start) start = gfc_copy_expr (char_ref->u.ss.start); else - start = gfc_int_expr (1); + start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); if (char_ref->u.ss.end) end = gfc_copy_expr (char_ref->u.ss.end); @@ -4243,7 +4661,9 @@ gfc_resolve_substring_charlen (gfc_expr *e) /* Length = (end - start +1). */ e->ts.u.cl->length = gfc_subtract (end, start); - e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, gfc_int_expr (1)); + e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, + gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1)); e->ts.u.cl->length->ts.type = BT_INTEGER; e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind; @@ -4299,6 +4719,13 @@ resolve_ref (gfc_expr *expr) switch (ref->u.ar.type) { case AR_FULL: + /* Coarray scalar. */ + if (ref->u.ar.as->rank == 0) + { + current_part_dimension = 0; + break; + } + /* Fall through. */ case AR_SECTION: current_part_dimension = 1; break; @@ -4470,11 +4897,26 @@ resolve_variable (gfc_expr *e) if (e->symtree == NULL) return FAILURE; + sym = e->symtree->n.sym; + + /* If this is an associate-name, it may be parsed with an array reference + in error even though the target is scalar. Fail directly in this case. */ + if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY) + return FAILURE; + + /* On the other hand, the parser may not have known this is an array; + in this case, we have to add a FULL reference. */ + if (sym->assoc && sym->attr.dimension && !e->ref) + { + e->ref = gfc_get_ref (); + e->ref->type = REF_ARRAY; + e->ref->u.ar.type = AR_FULL; + e->ref->u.ar.dimen = 0; + } if (e->ref && resolve_ref (e) == FAILURE) return FAILURE; - sym = e->symtree->n.sym; if (sym->attr.flavor == FL_PROCEDURE && (!sym->attr.function || (sym->attr.function && sym->result @@ -4564,10 +5006,60 @@ 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; + /* F2008, C617 and C1229. */ + if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED) + && gfc_is_coindexed (e)) + { + gfc_ref *ref, *ref2 = NULL; + + if (e->ts.type == BT_CLASS) + { + gfc_error ("Polymorphic subobject of coindexed object at %L", + &e->where); + t = FAILURE; + } + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT) + ref2 = ref; + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + break; + } + + for ( ; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + break; + + /* Expression itself is coindexed object. */ + if (ref == NULL) + { + gfc_component *c; + c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components; + for ( ; c; c = c->next) + if (c->attr.allocatable && c->ts.type == BT_CLASS) + { + gfc_error ("Coindexed object with polymorphic allocatable " + "subcomponent at %L", &e->where); + t = FAILURE; + break; + } + } + } + return t; } @@ -4692,12 +5184,14 @@ gfc_resolve_character_operator (gfc_expr *e) if (op1->ts.u.cl && op1->ts.u.cl->length) e1 = gfc_copy_expr (op1->ts.u.cl->length); else if (op1->expr_type == EXPR_CONSTANT) - e1 = gfc_int_expr (op1->value.character.length); + e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL, + op1->value.character.length); if (op2->ts.u.cl && op2->ts.u.cl->length) e2 = gfc_copy_expr (op2->ts.u.cl->length); else if (op2->expr_type == EXPR_CONSTANT) - e2 = gfc_int_expr (op2->value.character.length); + e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL, + op2->value.character.length); e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); @@ -4969,15 +5463,54 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target, } +/* Get the ultimate declared type from an expression. In addition, + return the last class/derived type reference and the copy of the + reference list. */ +static gfc_symbol* +get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, + gfc_expr *e) +{ + gfc_symbol *declared; + gfc_ref *ref; + + declared = NULL; + if (class_ref) + *class_ref = NULL; + if (new_ref) + *new_ref = gfc_copy_ref (e->ref); + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type != REF_COMPONENT) + continue; + + if (ref->u.c.component->ts.type == BT_CLASS + || ref->u.c.component->ts.type == BT_DERIVED) + { + declared = ref->u.c.component->ts.u.derived; + if (class_ref) + *class_ref = ref; + } + } + + if (declared == NULL) + declared = e->symtree->n.sym->ts.u.derived; + + return declared; +} + + /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out which of the specific bindings (if any) matches the arglist and transform the expression into a call of that binding. */ static gfc_try -resolve_typebound_generic_call (gfc_expr* e) +resolve_typebound_generic_call (gfc_expr* e, const char **name) { gfc_typebound_proc* genproc; const char* genname; + gfc_symtree *st; + gfc_symbol *derived; gcc_assert (e->expr_type == EXPR_COMPCALL); genname = e->value.compcall.name; @@ -5030,6 +5563,11 @@ resolve_typebound_generic_call (gfc_expr* e) 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 = genname; goto success; } } @@ -5041,6 +5579,13 @@ resolve_typebound_generic_call (gfc_expr* e) return FAILURE; success: + /* Make sure that we have the right specific instance for the name. */ + derived = get_declared_from_expr (NULL, NULL, e); + + st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where); + if (st) + e->value.compcall.tbp = st->n.tb; + return SUCCESS; } @@ -5048,7 +5593,7 @@ success: /* Resolve a call to a type-bound subroutine. */ static gfc_try -resolve_typebound_call (gfc_code* c) +resolve_typebound_call (gfc_code* c, const char **name) { gfc_actual_arglist* newactual; gfc_symtree* target; @@ -5064,7 +5609,12 @@ resolve_typebound_call (gfc_code* c) if (check_typebound_baseobject (c->expr1) == FAILURE) return FAILURE; - if (resolve_typebound_generic_call (c->expr1) == FAILURE) + /* Pass along the name for CLASS methods, where the vtab + procedure pointer component has to be referenced. */ + if (name) + *name = c->expr1->value.compcall.name; + + if (resolve_typebound_generic_call (c->expr1, name) == FAILURE) return FAILURE; /* Transform into an ordinary EXEC_CALL for now. */ @@ -5088,31 +5638,20 @@ resolve_typebound_call (gfc_code* c) } -/* Resolve a component-call expression. This originally was intended - only to see functions. However, it is convenient to use it in - resolving subroutine class methods, since we do not have to add a - gfc_code each time. */ +/* Resolve a component-call expression. */ static gfc_try -resolve_compcall (gfc_expr* e, bool fcn, bool class_members) +resolve_compcall (gfc_expr* e, const char **name) { gfc_actual_arglist* newactual; gfc_symtree* target; /* Check that's really a FUNCTION. */ - if (fcn && !e->value.compcall.tbp->function) + if (!e->value.compcall.tbp->function) { gfc_error ("'%s' at %L should be a FUNCTION", e->value.compcall.name, &e->where); return FAILURE; } - else if (!fcn && !e->value.compcall.tbp->subroutine) - { - /* To resolve class member calls, we borrow this bit - of code to select the specific procedures. */ - gfc_error ("'%s' at %L should be a SUBROUTINE", - e->value.compcall.name, &e->where); - return FAILURE; - } /* These must not be assign-calls! */ gcc_assert (!e->value.compcall.assign); @@ -5120,7 +5659,12 @@ resolve_compcall (gfc_expr* e, bool fcn, bool class_members) if (check_typebound_baseobject (e) == FAILURE) return FAILURE; - if (resolve_typebound_generic_call (e) == FAILURE) + /* Pass along the name for CLASS methods, where the vtab + procedure pointer component has to be referenced. */ + if (name) + *name = e->value.compcall.name; + + if (resolve_typebound_generic_call (e, name) == FAILURE) return FAILURE; gcc_assert (!e->value.compcall.tbp->is_generic); @@ -5137,336 +5681,191 @@ resolve_compcall (gfc_expr* e, bool fcn, bool class_members) e->value.function.actual = newactual; e->value.function.name = NULL; e->value.function.esym = target->n.sym; - e->value.function.class_esym = NULL; e->value.function.isym = NULL; e->symtree = target; e->ts = target->n.sym->ts; e->expr_type = EXPR_FUNCTION; - /* Resolution is not necessary when constructing component calls - for class members, since this must only be done for the - declared type, which is done afterwards. */ - return !class_members ? gfc_resolve_expr (e) : SUCCESS; -} - - -/* Resolve a typebound call for the members in a class. This group of - functions implements dynamic dispatch in the provisional version - of f03 OOP. As soon as vtables are in place and contain pointers - to methods, this will no longer be necessary. */ -static gfc_expr *list_e; -static void check_class_members (gfc_symbol *); -static gfc_try class_try; -static bool fcn_flag; - - -static void -check_members (gfc_symbol *derived) -{ - if (derived->attr.flavor == FL_DERIVED) - check_class_members (derived); -} - - -static void -check_class_members (gfc_symbol *derived) -{ - gfc_expr *e; - gfc_symtree *tbp; - gfc_class_esym_list *etmp; - - e = gfc_copy_expr (list_e); - - tbp = gfc_find_typebound_proc (derived, &class_try, - e->value.compcall.name, - false, &e->where); - - if (tbp == NULL) - { - gfc_error ("no typebound available procedure named '%s' at %L", - e->value.compcall.name, &e->where); - return; - } - - /* If we have to match a passed class member, force the actual - expression to have the correct type. */ - if (!tbp->n.tb->nopass) - { - if (e->value.compcall.base_object == NULL) - e->value.compcall.base_object = extract_compcall_passed_object (e); - - if (!derived->attr.abstract) - { - e->value.compcall.base_object->ts.type = BT_DERIVED; - e->value.compcall.base_object->ts.u.derived = derived; - } - } - - e->value.compcall.tbp = tbp->n.tb; - e->value.compcall.name = tbp->name; - - /* Let the original expresssion catch the assertion in - resolve_compcall, since this flag does not appear to be reset or - copied in some systems. */ - e->value.compcall.assign = 0; - - /* Do the renaming, PASSing, generic => specific and other - good things for each class member. */ - class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS) - ? class_try : FAILURE; - - /* Now transfer the found symbol to the esym list. */ - if (class_try == SUCCESS) - { - etmp = list_e->value.function.class_esym; - list_e->value.function.class_esym - = gfc_get_class_esym_list(); - list_e->value.function.class_esym->next = etmp; - list_e->value.function.class_esym->derived = derived; - list_e->value.function.class_esym->esym - = e->value.function.esym; - } - - gfc_free_expr (e); - - /* Burrow down into grandchildren types. */ - if (derived->f2k_derived) - gfc_traverse_ns (derived->f2k_derived, check_members); -} - - -/* Eliminate esym_lists where all the members point to the - typebound procedure of the declared type; ie. one where - type selection has no effect.. */ -static void -resolve_class_esym (gfc_expr *e) -{ - gfc_class_esym_list *p, *q; - bool empty = true; - - gcc_assert (e && e->expr_type == EXPR_FUNCTION); - - p = e->value.function.class_esym; - if (p == NULL) - return; - - for (; p; p = p->next) - empty = empty && (e->value.function.esym == p->esym); - - if (empty) - { - p = e->value.function.class_esym; - for (; p; p = q) - { - q = p->next; - gfc_free (p); - } - e->value.function.class_esym = NULL; - } -} - - -/* Generate an expression for the hash value, given the reference to - the class of the final expression (class_ref), the base of the - full reference list (new_ref), the declared type and the class - object (st). */ -static gfc_expr* -hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st) -{ - gfc_expr *hash_value; - - /* Build an expression for the correct hash_value; ie. that of the last - CLASS reference. */ - if (class_ref) - { - class_ref->next = NULL; - } - else - { - gfc_free_ref_list (new_ref); - new_ref = NULL; - } - hash_value = gfc_get_expr (); - hash_value->expr_type = EXPR_VARIABLE; - hash_value->symtree = st; - hash_value->symtree->n.sym->refs++; - hash_value->ref = new_ref; - gfc_add_component_ref (hash_value, "$vptr"); - gfc_add_component_ref (hash_value, "$hash"); - - return hash_value; -} - - -/* Get the ultimate declared type from an expression. In addition, - return the last class/derived type reference and the copy of the - reference list. */ -static gfc_symbol* -get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, - gfc_expr *e) -{ - gfc_symbol *declared; - gfc_ref *ref; - - declared = NULL; - *class_ref = NULL; - *new_ref = gfc_copy_ref (e->ref); - for (ref = *new_ref; ref; ref = ref->next) - { - if (ref->type != REF_COMPONENT) - continue; - - if (ref->u.c.component->ts.type == BT_CLASS - || ref->u.c.component->ts.type == BT_DERIVED) - { - declared = ref->u.c.component->ts.u.derived; - *class_ref = ref; - } - } - - if (declared == NULL) - declared = e->symtree->n.sym->ts.u.derived; - - return declared; + /* Resolution is not necessary if this is a class subroutine; this + function only has to identify the specific proc. Resolution of + the call will be done next in resolve_typebound_call. */ + return gfc_resolve_expr (e); } -/* Resolve the argument expressions so that any arguments expressions - that include class methods are resolved before the current call. - This is necessary because of the static variables used in CLASS - method resolution. */ -static void -resolve_arg_exprs (gfc_actual_arglist *arg) -{ - /* Resolve the actual arglist expressions. */ - for (; arg; arg = arg->next) - { - if (arg->expr) - gfc_resolve_expr (arg->expr); - } -} - -/* Resolve a typebound function, or 'method'. First separate all - the non-CLASS references by calling resolve_compcall directly. - Then treat the CLASS references by resolving for each of the class - members in turn. */ +/* Resolve a typebound function, or 'method'. First separate all + the non-CLASS references by calling resolve_compcall directly. */ static gfc_try resolve_typebound_function (gfc_expr* e) { - gfc_symbol *derived, *declared; + gfc_symbol *declared; + gfc_component *c; gfc_ref *new_ref; gfc_ref *class_ref; gfc_symtree *st; + const char *name; + 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, true, false); + return resolve_compcall (e, NULL); + + if (resolve_ref (e) == FAILURE) + return FAILURE; /* Get the CLASS declared type. */ declared = get_declared_from_expr (&class_ref, &new_ref, e); /* Weed out cases of the ultimate component being a derived type. */ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) - || (!class_ref && st->n.sym->ts.type != BT_CLASS)) + || (!class_ref && st->n.sym->ts.type != BT_CLASS)) { gfc_free_ref_list (new_ref); - return resolve_compcall (e, true, false); + return resolve_compcall (e, NULL); } - /* Resolve the argument expressions, */ - resolve_arg_exprs (e->value.function.actual); + c = gfc_find_component (declared, "$data", true, true); + declared = c->ts.u.derived; - /* Get the data component, which is of the declared type. */ - derived = declared->components->ts.u.derived; - - /* Resolve the function call for each member of the class. */ - class_try = SUCCESS; - fcn_flag = true; - list_e = gfc_copy_expr (e); - check_class_members (derived); - - class_try = (resolve_compcall (e, true, false) == SUCCESS) - ? class_try : FAILURE; + /* 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) + return FAILURE; + ts = e->ts; - /* Transfer the class list to the original expression. Note that - the class_esym list is cleaned up in trans-expr.c, as the calls - are translated. */ - e->value.function.class_esym = list_e->value.function.class_esym; - list_e->value.function.class_esym = NULL; - gfc_free_expr (list_e); + /* Then convert the expression to a procedure pointer component call. */ + e->value.function.esym = NULL; + e->symtree = st; - resolve_class_esym (e); + if (new_ref) + e->ref = new_ref; - /* More than one typebound procedure so transmit an expression for - the hash_value as the selector. */ - if (e->value.function.class_esym != NULL) - e->value.function.class_esym->hash_value - = hash_value_expr (class_ref, new_ref, st); + /* '$vptr' points to the vtab, which contains the procedure pointers. */ + gfc_add_component_ref (e, "$vptr"); + gfc_add_component_ref (e, name); - return class_try; + /* Recover the typespec for the expression. This is really only + necessary for generic procedures, where the additional call + to gfc_add_component_ref seems to throw the collection of the + correct typespec. */ + e->ts = ts; + return SUCCESS; } -/* Resolve a typebound subroutine, or 'method'. First separate all - the non-CLASS references by calling resolve_typebound_call directly. - Then treat the CLASS references by resolving for each of the class - members in turn. */ +/* Resolve a typebound subroutine, or 'method'. First separate all + the non-CLASS references by calling resolve_typebound_call + directly. */ static gfc_try resolve_typebound_subroutine (gfc_code *code) { - gfc_symbol *derived, *declared; + gfc_symbol *declared; + gfc_component *c; gfc_ref *new_ref; gfc_ref *class_ref; gfc_symtree *st; + 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); + return resolve_typebound_call (code, NULL); + + if (resolve_ref (code->expr1) == FAILURE) + return FAILURE; /* Get the CLASS declared type. */ - declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1); + 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) - || (!class_ref && st->n.sym->ts.type != BT_CLASS)) + || (!class_ref && st->n.sym->ts.type != BT_CLASS)) { gfc_free_ref_list (new_ref); - return resolve_typebound_call (code); - } - - /* Resolve the argument expressions, */ - resolve_arg_exprs (code->expr1->value.compcall.actual); - - /* Get the data component, which is of the declared type. */ - derived = declared->components->ts.u.derived; - - class_try = SUCCESS; - fcn_flag = false; - list_e = gfc_copy_expr (code->expr1); - check_class_members (derived); + return resolve_typebound_call (code, NULL); + } - class_try = (resolve_typebound_call (code) == SUCCESS) - ? class_try : FAILURE; + if (resolve_typebound_call (code, &name) == FAILURE) + return FAILURE; + ts = code->expr1->ts; - /* Transfer the class list to the original expression. Note that - the class_esym list is cleaned up in trans-expr.c, as the calls - are translated. */ - code->expr1->value.function.class_esym - = list_e->value.function.class_esym; - list_e->value.function.class_esym = NULL; - gfc_free_expr (list_e); + /* Then convert the expression to a procedure pointer component call. */ + code->expr1->value.function.esym = NULL; + code->expr1->symtree = st; - resolve_class_esym (code->expr1); + if (new_ref) + code->expr1->ref = new_ref; - /* More than one typebound procedure so transmit an expression for - the hash_value as the selector. */ - if (code->expr1->value.function.class_esym != NULL) - code->expr1->value.function.class_esym->hash_value - = hash_value_expr (class_ref, new_ref, st); + /* '$vptr' points to the vtab, which contains the procedure pointers. */ + gfc_add_component_ref (code->expr1, "$vptr"); + gfc_add_component_ref (code->expr1, name); - return class_try; + /* Recover the typespec for the expression. This is really only + necessary for generic procedures, where the additional call + to gfc_add_component_ref seems to throw the collection of the + correct typespec. */ + code->expr1->ts = ts; + return SUCCESS; } @@ -5553,15 +5952,16 @@ gfc_is_expandable_expr (gfc_expr *e) /* Traverse the constructor looking for variables that are flavor parameter. Parameters must be expanded since they are fully used at compile time. */ - for (con = e->value.constructor; con; con = con->next) + con = gfc_constructor_first (e->value.constructor); + for (; con; con = gfc_constructor_next (con)) { if (con->expr->expr_type == EXPR_VARIABLE - && con->expr->symtree - && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER + && con->expr->symtree + && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE)) return true; if (con->expr->expr_type == EXPR_ARRAY - && gfc_is_expandable_expr (con->expr)) + && gfc_is_expandable_expr (con->expr)) return true; } } @@ -5577,10 +5977,16 @@ gfc_try gfc_resolve_expr (gfc_expr *e) { gfc_try t; + bool inquiry_save; if (e == NULL) return SUCCESS; + /* inquiry_argument only applies to variables. */ + inquiry_save = inquiry_argument; + if (e->expr_type != EXPR_VARIABLE) + inquiry_argument = false; + switch (e->expr_type) { case EXPR_OP: @@ -5633,7 +6039,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 @@ -5643,7 +6049,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); } @@ -5654,7 +6060,7 @@ gfc_resolve_expr (gfc_expr *e) if (t == FAILURE) break; - t = resolve_structure_cons (e); + t = resolve_structure_cons (e, 0); if (t == FAILURE) break; @@ -5668,6 +6074,8 @@ gfc_resolve_expr (gfc_expr *e) if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl) fixup_charlen (e); + inquiry_argument = inquiry_save; + return t; } @@ -5941,8 +6349,8 @@ resolve_deallocate_expr (gfc_expr *e) if (sym->ts.type == BT_CLASS) { - allocatable = sym->ts.u.derived->components->attr.allocatable; - pointer = sym->ts.u.derived->components->attr.pointer; + allocatable = CLASS_DATA (sym)->attr.allocatable; + pointer = CLASS_DATA (sym)->attr.class_pointer; } else { @@ -5965,8 +6373,8 @@ resolve_deallocate_expr (gfc_expr *e) c = ref->u.c.component; if (c->ts.type == BT_CLASS) { - allocatable = c->ts.u.derived->components->attr.allocatable; - pointer = c->ts.u.derived->components->attr.pointer; + allocatable = CLASS_DATA (c)->attr.allocatable; + pointer = CLASS_DATA (c)->attr.class_pointer; } else { @@ -5988,6 +6396,7 @@ resolve_deallocate_expr (gfc_expr *e) bad: gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", &e->where); + return FAILURE; } if (check_intent_in && sym->attr.intent == INTENT_IN) @@ -6062,8 +6471,11 @@ gfc_expr_to_initialize (gfc_expr *e) static gfc_try conformable_arrays (gfc_expr *e1, gfc_expr *e2) { + gfc_ref *tail; + for (tail = e2->ref; tail && tail->next; tail = tail->next); + /* First compare rank. */ - if (e2->ref && e1->rank != e2->ref->u.ar.as->rank) + if (tail && e1->rank != tail->u.ar.as->rank) { gfc_error ("Source-expr at %L must be scalar or have the " "same rank as the allocate-object at %L", @@ -6080,15 +6492,15 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) for (i = 0; i < e1->rank; i++) { - if (e2->ref->u.ar.end[i]) + if (tail->u.ar.end[i]) { - mpz_set (s, e2->ref->u.ar.end[i]->value.integer); - mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer); + mpz_set (s, tail->u.ar.end[i]->value.integer); + mpz_sub (s, s, tail->u.ar.start[i]->value.integer); mpz_add_ui (s, s, 1); } else { - mpz_set (s, e2->ref->u.ar.start[i]->value.integer); + mpz_set (s, tail->u.ar.start[i]->value.integer); } if (mpz_cmp (e1->shape[i], s) != 0) @@ -6115,19 +6527,28 @@ static gfc_try resolve_allocate_expr (gfc_expr *e, gfc_code *code) { int i, pointer, allocatable, dimension, check_intent_in, is_abstract; + int codimension; symbol_attribute attr; gfc_ref *ref, *ref2; gfc_array_ref *ar; - gfc_symbol *sym; + gfc_symbol *sym = NULL; gfc_alloc *a; gfc_component *c; - gfc_expr *init_e; /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ check_intent_in = 1; + /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR + checking of coarrays. */ + for (ref = e->ref; ref; ref = ref->next) + if (ref->next == NULL) + break; + + if (ref && ref->type == REF_ARRAY) + ref->u.ar.in_allocate = true; + if (gfc_resolve_expr (e) == FAILURE) - return FAILURE; + goto failure; /* Make sure the expression is allocatable or a pointer. If it is pointer, the next-to-last reference must be a pointer. */ @@ -6145,21 +6566,24 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) attr = gfc_expr_attr (e); pointer = attr.pointer; dimension = attr.dimension; + codimension = attr.codimension; } else { if (sym->ts.type == BT_CLASS) { - allocatable = sym->ts.u.derived->components->attr.allocatable; - pointer = sym->ts.u.derived->components->attr.pointer; - dimension = sym->ts.u.derived->components->attr.dimension; - is_abstract = sym->ts.u.derived->components->attr.abstract; + allocatable = CLASS_DATA (sym)->attr.allocatable; + 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; } else { allocatable = sym->attr.allocatable; pointer = sym->attr.pointer; dimension = sym->attr.dimension; + codimension = sym->attr.codimension; } for (ref = e->ref; ref; ref2 = ref, ref = ref->next) @@ -6175,19 +6599,29 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) break; case REF_COMPONENT: + /* F2008, C644. */ + if (gfc_is_coindexed (e)) + { + gfc_error ("Coindexed allocatable object at %L", + &e->where); + goto failure; + } + c = ref->u.c.component; if (c->ts.type == BT_CLASS) { - allocatable = c->ts.u.derived->components->attr.allocatable; - pointer = c->ts.u.derived->components->attr.pointer; - dimension = c->ts.u.derived->components->attr.dimension; - is_abstract = c->ts.u.derived->components->attr.abstract; + allocatable = CLASS_DATA (c)->attr.allocatable; + 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; } else { allocatable = c->attr.allocatable; pointer = c->attr.pointer; dimension = c->attr.dimension; + codimension = c->attr.codimension; is_abstract = c->attr.abstract; } break; @@ -6204,7 +6638,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) { gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", &e->where); - return FAILURE; + goto failure; } /* Some checks for the SOURCE tag. */ @@ -6215,13 +6649,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) { gfc_error ("Type of entity at %L is type incompatible with " "source-expr at %L", &e->where, &code->expr3->where); - return FAILURE; + goto failure; } /* Check F03:C632 and restriction following Note 6.18. */ if (code->expr3->rank > 0 && conformable_arrays (code->expr3, e) == FAILURE) - return FAILURE; + goto failure; /* Check F03:C633. */ if (code->expr3->ts.kind != e->ts.kind) @@ -6229,44 +6663,43 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) gfc_error ("The allocate-object at %L and the source-expr at %L " "shall have the same kind type parameter", &e->where, &code->expr3->where); - return FAILURE; + goto failure; } } - else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN) + + /* Check F08:C629. */ + if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN + && !code->expr3) { gcc_assert (e->ts.type == BT_CLASS); gfc_error ("Allocating %s of ABSTRACT base type at %L requires a " - "type-spec or SOURCE=", sym->name, &e->where); - return FAILURE; + "type-spec or source-expr", sym->name, &e->where); + goto failure; } if (check_intent_in && sym->attr.intent == INTENT_IN) { gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L", sym->name, &e->where); - return FAILURE; + goto failure; } - + if (!code->expr3) { - /* Add default initializer for those derived types that need them. */ - if (e->ts.type == BT_DERIVED - && (init_e = gfc_default_initializer (&e->ts))) - { - gfc_code *init_st = gfc_get_code (); - init_st->loc = code->loc; - init_st->op = EXEC_INIT_ASSIGN; - init_st->expr1 = gfc_expr_to_initialize (e); - init_st->expr2 = init_e; - init_st->next = code->next; - code->next = init_st; - } - else if (e->ts.type == BT_CLASS - && ((code->ext.alloc.ts.type == BT_UNKNOWN - && (init_e = gfc_default_initializer (&e->ts.u.derived->components->ts))) - || (code->ext.alloc.ts.type == BT_DERIVED - && (init_e = gfc_default_initializer (&code->ext.alloc.ts))))) + /* Set up default initializer if needed. */ + gfc_typespec ts; + + if (code->ext.alloc.ts.type == BT_DERIVED) + ts = code->ext.alloc.ts; + else + ts = e->ts; + + if (ts.type == BT_CLASS) + ts = ts.u.derived->components->ts; + + if (ts.type == BT_DERIVED && gfc_has_default_initializer(ts.u.derived)) { + gfc_expr *init_e = gfc_default_initializer (&ts); gfc_code *init_st = gfc_get_code (); init_st->loc = code->loc; init_st->op = EXEC_INIT_ASSIGN; @@ -6276,17 +6709,38 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) code->next = init_st; } } + else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED) + { + /* Default initialization via MOLD (non-polymorphic). */ + gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts); + gfc_resolve_expr (rhs); + gfc_free_expr (code->expr3); + code->expr3 = rhs; + } - if (pointer || dimension == 0) - return SUCCESS; + if (e->ts.type == BT_CLASS) + { + /* Make sure the vtab symbol is present when + the module variables are generated. */ + gfc_typespec ts = e->ts; + if (code->expr3) + ts = code->expr3->ts; + else if (code->ext.alloc.ts.type == BT_DERIVED) + ts = code->ext.alloc.ts; + gfc_find_derived_vtab (ts.u.derived); + } + + if (pointer || (dimension == 0 && codimension == 0)) + goto success; /* Make sure the next-to-last reference node is an array specification. */ - if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL) + if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL + || (dimension && ref2->u.ar.dimen == 0)) { gfc_error ("Array specification required in ALLOCATE statement " "at %L", &e->where); - return FAILURE; + goto failure; } /* Make sure that the array section reference makes sense in the @@ -6294,6 +6748,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) ar = &ref2->u.ar; + if (codimension && ar->codimen == 0) + { + gfc_error ("Coarray specification required in ALLOCATE statement " + "at %L", &e->where); + goto failure; + } + for (i = 0; i < ar->dimen; i++) { if (ref2->u.ar.type == AR_ELEMENT) @@ -6314,13 +6775,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) case DIMEN_UNKNOWN: case DIMEN_VECTOR: + case DIMEN_STAR: gfc_error ("Bad array specification in ALLOCATE statement at %L", &e->where); - return FAILURE; + goto failure; } check_symbols: - for (a = code->ext.alloc.list; a; a = a->next) { sym = a->expr->symtree->n.sym; @@ -6337,12 +6798,46 @@ check_symbols: gfc_error ("'%s' must not appear in the array specification at " "%L in the same ALLOCATE statement where it is " "itself allocated", sym->name, &ar->where); - return FAILURE; + goto failure; } } } + for (i = ar->dimen; i < ar->codimen + ar->dimen; i++) + { + if (ar->dimen_type[i] == DIMEN_ELEMENT + || ar->dimen_type[i] == DIMEN_RANGE) + { + if (i == (ar->dimen + ar->codimen - 1)) + { + gfc_error ("Expected '*' in coindex specification in ALLOCATE " + "statement at %L", &e->where); + goto failure; + } + break; + } + + if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1) + && ar->stride[i] == NULL) + break; + + gfc_error ("Bad coarray specification in ALLOCATE statement at %L", + &e->where); + goto failure; + } + + if (codimension && ar->as->rank == 0) + { + gfc_error ("Sorry, allocatable scalar coarrays are not yet supported " + "at %L", &e->where); + goto failure; + } + +success: return SUCCESS; + +failure: + return FAILURE; } static void @@ -6375,8 +6870,29 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) for (p = code->ext.alloc.list; p; p = p->next) if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name) - gfc_error ("Stat-variable at %L shall not be %sd within " - "the same %s statement", &stat->where, fcn, fcn); + { + gfc_ref *ref1, *ref2; + bool found = true; + + for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2; + ref1 = ref1->next, ref2 = ref2->next) + { + if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT) + continue; + if (ref1->u.c.component->name != ref2->u.c.component->name) + { + found = false; + break; + } + } + + if (found) + { + gfc_error ("Stat-variable at %L shall not be %sd within " + "the same %s statement", &stat->where, fcn, fcn); + break; + } + } } /* Check the errmsg variable. */ @@ -6404,8 +6920,29 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) for (p = code->ext.alloc.list; p; p = p->next) if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name) - gfc_error ("Errmsg-variable at %L shall not be %sd within " - "the same %s statement", &errmsg->where, fcn, fcn); + { + gfc_ref *ref1, *ref2; + bool found = true; + + for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2; + ref1 = ref1->next, ref2 = ref2->next) + { + if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT) + continue; + if (ref1->u.c.component->name != ref2->u.c.component->name) + { + found = false; + break; + } + } + + if (found) + { + gfc_error ("Errmsg-variable at %L shall not be %sd within " + "the same %s statement", &errmsg->where, fcn, fcn); + break; + } + } } /* Check that an allocate-object appears only once in the statement. @@ -6656,8 +7193,9 @@ validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr) return FAILURE; } - /* Convert the case value kind to that of case expression kind, if needed. - FIXME: Should a warning be issued? */ + /* Convert the case value kind to that of case expression kind, + if needed */ + if (e->ts.kind != case_expr->ts.kind) gfc_convert_type_warn (e, &case_expr->ts, 2, 0); @@ -6743,6 +7281,31 @@ resolve_select (gfc_code *code) return; } + + /* Raise a warning if an INTEGER case value exceeds the range of + the case-expr. Later, all expressions will be promoted to the + largest kind of all case-labels. */ + + if (type == BT_INTEGER) + for (body = code->block; body; body = body->block) + for (cp = body->ext.case_list; cp; cp = cp->next) + { + if (cp->low + && gfc_check_integer_range (cp->low->value.integer, + case_expr->ts.kind) != ARITH_OK) + gfc_warning ("Expression in CASE statement at %L is " + "not in the range of %s", &cp->low->where, + gfc_typename (&case_expr->ts)); + + if (cp->high + && cp->low != cp->high + && gfc_check_integer_range (cp->high->value.integer, + case_expr->ts.kind) != ARITH_OK) + gfc_warning ("Expression in CASE statement at %L is " + "not in the range of %s", &cp->high->where, + gfc_typename (&case_expr->ts)); + } + /* PR 19168 has a long discussion concerning a mismatch of the kinds of the SELECT CASE expression and its CASE values. Walk the lists of case values, and if we find a mismatch, promote case_expr to @@ -6765,7 +7328,6 @@ resolve_select (gfc_code *code) && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0) continue; - /* FIXME: Should a warning be issued? */ if (cp->low != NULL && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low)) gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0); @@ -6816,8 +7378,8 @@ resolve_select (gfc_code *code) /* Deal with single value cases and case ranges. Errors are issued from the validation function. */ - if(validate_case_label_expr (cp->low, case_expr) != SUCCESS - || validate_case_label_expr (cp->high, case_expr) != SUCCESS) + if (validate_case_label_expr (cp->low, case_expr) != SUCCESS + || validate_case_label_expr (cp->high, case_expr) != SUCCESS) { t = FAILURE; break; @@ -6839,7 +7401,7 @@ resolve_select (gfc_code *code) value = cp->low->value.logical == 0 ? 2 : 1; if (value & seen_logical) { - gfc_error ("constant logical value in CASE statement " + gfc_error ("Constant logical value in CASE statement " "is repeated at %L", &cp->low->where); t = FAILURE; @@ -6970,6 +7532,88 @@ gfc_type_is_extensible (gfc_symbol *sym) } +/* Resolve an associate name: Resolve target and ensure the type-spec is + correct as well as possibly the array-spec. */ + +static void +resolve_assoc_var (gfc_symbol* sym, bool resolve_target) +{ + gfc_expr* target; + bool to_var; + + gcc_assert (sym->assoc); + gcc_assert (sym->attr.flavor == FL_VARIABLE); + + /* If this is for SELECT TYPE, the target may not yet be set. In that + case, return. Resolution will be called later manually again when + this is done. */ + target = sym->assoc->target; + if (!target) + return; + gcc_assert (!sym->assoc->dangling); + + if (resolve_target && gfc_resolve_expr (target) != SUCCESS) + return; + + /* For variable targets, we get some attributes from the target. */ + if (target->expr_type == EXPR_VARIABLE) + { + gfc_symbol* tsym; + + gcc_assert (target->symtree); + tsym = target->symtree->n.sym; + + sym->attr.asynchronous = tsym->attr.asynchronous; + sym->attr.volatile_ = tsym->attr.volatile_; + + sym->attr.target = (tsym->attr.target || tsym->attr.pointer); + } + + sym->ts = target->ts; + gcc_assert (sym->ts.type != BT_UNKNOWN); + + /* See if this is a valid association-to-variable. */ + to_var = (target->expr_type == EXPR_VARIABLE + && !gfc_has_vector_subscript (target)); + if (sym->assoc->variable && !to_var) + { + if (target->expr_type == EXPR_VARIABLE) + gfc_error ("'%s' at %L associated to vector-indexed target can not" + " be used in a variable definition context", + sym->name, &sym->declared_at); + else + gfc_error ("'%s' at %L associated to expression can not" + " be used in a variable definition context", + sym->name, &sym->declared_at); + + return; + } + sym->assoc->variable = to_var; + + /* Finally resolve if this is an array or not. */ + if (sym->attr.dimension && target->rank == 0) + { + gfc_error ("Associate-name '%s' at %L is used as array", + sym->name, &sym->declared_at); + sym->attr.dimension = 0; + return; + } + if (target->rank > 0) + sym->attr.dimension = 1; + + if (sym->attr.dimension) + { + sym->as = gfc_get_array_spec (); + sym->as->rank = target->rank; + sym->as->type = AS_DEFERRED; + + /* Target must not be coindexed, thus the associate-variable + has no corank. */ + sym->as->corank = 0; + } +} + + /* Resolve a SELECT TYPE statement. */ static void @@ -6984,13 +7628,26 @@ resolve_select_type (gfc_code *code) gfc_namespace *ns; int error = 0; - ns = code->ext.ns; + ns = code->ext.block.ns; gfc_resolve (ns); + /* Check for F03:C813. */ + if (code->expr1->ts.type != BT_CLASS + && !(code->expr2 && code->expr2->ts.type == BT_CLASS)) + { + gfc_error ("Selector shall be polymorphic in SELECT TYPE statement " + "at %L", &code->loc); + return; + } + if (code->expr2) - selector_type = code->expr2->ts.u.derived->components->ts.u.derived; + { + if (code->expr1->symtree->n.sym->attr.untyped) + code->expr1->symtree->n.sym->ts = code->expr2->ts; + selector_type = CLASS_DATA (code->expr2)->ts.u.derived; + } else - selector_type = code->expr1->ts.u.derived->components->ts.u.derived; + selector_type = CLASS_DATA (code->expr1)->ts.u.derived; /* Loop over TYPE IS / CLASS IS cases. */ for (body = code->block; body; body = body->block) @@ -7034,36 +7691,45 @@ resolve_select_type (gfc_code *code) } } - if (error>0) + if (error > 0) return; + /* Transform SELECT TYPE statement to BLOCK and associate selector to + target if present. If there are any EXIT statements referring to the + SELECT TYPE construct, this is no problem because the gfc_code + reference stays the same and EXIT is equally possible from the BLOCK + it is changed to. */ + code->op = EXEC_BLOCK; if (code->expr2) { - /* Insert assignment for selector variable. */ - new_st = gfc_get_code (); - new_st->op = EXEC_ASSIGN; - new_st->expr1 = gfc_copy_expr (code->expr1); - new_st->expr2 = gfc_copy_expr (code->expr2); - ns->code = new_st; + gfc_association_list* assoc; + + assoc = gfc_get_association_list (); + assoc->st = code->expr1->symtree; + assoc->target = gfc_copy_expr (code->expr2); + /* assoc->variable will be set by resolve_assoc_var. */ + + code->ext.block.assoc = assoc; + code->expr1->symtree->n.sym->assoc = assoc; + + resolve_assoc_var (code->expr1->symtree->n.sym, false); } + else + code->ext.block.assoc = NULL; - /* Put SELECT TYPE statement inside a BLOCK. */ + /* Add EXEC_SELECT to switch on type. */ new_st = gfc_get_code (); new_st->op = code->op; new_st->expr1 = code->expr1; new_st->expr2 = code->expr2; new_st->block = code->block; + code->expr1 = code->expr2 = NULL; + code->block = NULL; if (!ns->code) ns->code = new_st; else ns->code->next = new_st; - code->op = EXEC_BLOCK; - code->expr1 = code->expr2 = NULL; - code->block = NULL; - code = new_st; - - /* Transform to EXEC_SELECT. */ code->op = EXEC_SELECT; gfc_add_component_ref (code->expr1, "$vptr"); gfc_add_component_ref (code->expr1, "$hash"); @@ -7072,30 +7738,45 @@ resolve_select_type (gfc_code *code) for (body = code->block; body; body = body->block) { c = body->ext.case_list; - + if (c->ts.type == BT_DERIVED) - c->low = c->high = gfc_int_expr (c->ts.u.derived->hash_value); + c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, + c->ts.u.derived->hash_value); + else if (c->ts.type == BT_UNKNOWN) continue; - - /* Assign temporary to selector. */ + + /* Associate temporary to selector. This should only be done + when this case is actually true, so build a new ASSOCIATE + that does precisely this here (instead of using the + 'global' one). */ + if (c->ts.type == BT_CLASS) sprintf (name, "tmp$class$%s", c->ts.u.derived->name); else sprintf (name, "tmp$type$%s", c->ts.u.derived->name); st = gfc_find_symtree (ns->sym_root, name); - new_st = gfc_get_code (); - new_st->expr1 = gfc_get_variable_expr (st); - new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree); + gcc_assert (st->n.sym->assoc); + st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree); if (c->ts.type == BT_DERIVED) + gfc_add_component_ref (st->n.sym->assoc->target, "$data"); + + new_st = gfc_get_code (); + new_st->op = EXEC_BLOCK; + new_st->ext.block.ns = gfc_build_block_ns (ns); + new_st->ext.block.ns->code = body->next; + body->next = new_st; + + /* Chain in the new list only if it is marked as dangling. Otherwise + there is a CASE label overlap and this is already used. Just ignore, + the error is diagonsed elsewhere. */ + if (st->n.sym->assoc->dangling) { - new_st->op = EXEC_POINTER_ASSIGN; - gfc_add_component_ref (new_st->expr2, "$data"); + new_st->ext.block.assoc = st->n.sym->assoc; + st->n.sym->assoc->dangling = 0; } - else - new_st->op = EXEC_POINTER_ASSIGN; - new_st->next = body->next; - body->next = new_st; + + resolve_assoc_var (st->n.sym, false); } /* Take out CLASS IS cases for separate treatment. */ @@ -7140,7 +7821,7 @@ resolve_select_type (gfc_code *code) tail->next = NULL; default_case = tail; } - + /* More than one CLASS IS block? */ if (class_is->block) { @@ -7235,7 +7916,12 @@ resolve_transfer (gfc_code *code) exp = code->expr1; - if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION) + while (exp != NULL && exp->expr_type == EXPR_OP + && exp->value.op.op == INTRINSIC_PARENTHESES) + exp = exp->value.op.op1; + + if (exp == NULL || (exp->expr_type != EXPR_VARIABLE + && exp->expr_type != EXPR_FUNCTION)) return; sym = exp->symtree->n.sym; @@ -7333,7 +8019,8 @@ resolve_sync (gfc_code *code) && gfc_simplify_expr (code->expr1, 0) == SUCCESS) { gfc_constructor *cons; - for (cons = code->expr1->value.constructor; cons; cons = cons->next) + cons = gfc_constructor_first (code->expr1->value.constructor); + for (; cons; cons = gfc_constructor_next (cons)) if (cons->expr->expr_type == EXPR_CONSTANT && mpz_cmp_si (cons->expr->value.integer, 1) < 0) gfc_error ("Imageset argument at %L must between 1 and " @@ -7798,10 +8485,11 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) static void resolve_block_construct (gfc_code* code) { - /* Eventually, we may want to do some checks here or handle special stuff. - But so far the only thing we can do is resolving the local namespace. */ + /* Resolve the BLOCK's namespace. */ + gfc_resolve (code->ext.block.ns); - gfc_resolve (code->ext.ns); + /* For an ASSOCIATE block, the associations (and their targets) are already + resolved during resolve_symbol. */ } @@ -7924,7 +8612,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) and rhs is the same symbol as the lhs. */ if ((*rhsptr)->expr_type == EXPR_VARIABLE && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED - && has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived) + && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived) && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym)) *rhsptr = gfc_get_parentheses (*rhsptr); @@ -8023,17 +8711,35 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) && lhs->expr_type == EXPR_VARIABLE && lhs->ts.u.derived->attr.pointer_comp && rhs->expr_type == EXPR_VARIABLE - && gfc_impure_variable (rhs->symtree->n.sym)) + && (gfc_impure_variable (rhs->symtree->n.sym) + || gfc_is_coindexed (rhs))) + { + /* F2008, C1283. */ + if (gfc_is_coindexed (rhs)) + gfc_error ("Coindexed expression at %L is assigned to " + "a derived type variable with a POINTER " + "component in a PURE procedure", + &rhs->where); + else + gfc_error ("The impure variable at %L is assigned to " + "a derived type variable with a POINTER " + "component in a PURE procedure (12.6)", + &rhs->where); + return rval; + } + + /* Fortran 2008, C1283. */ + if (gfc_is_coindexed (lhs)) { - gfc_error ("The impure variable at %L is assigned to " - "a derived type variable with a POINTER " - "component in a PURE procedure (12.6)", - &rhs->where); + gfc_error ("Assignment to coindexed variable at %L in a PURE " + "procedure", &rhs->where); return rval; } } /* F03:7.4.1.2. */ + /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic + and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */ if (lhs->ts.type == BT_CLASS) { gfc_error ("Variable must not be polymorphic in assignment at %L", @@ -8041,6 +8747,14 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) return false; } + /* F2008, Section 7.2.1.2. */ + if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs)) + { + gfc_error ("Coindexed variable must not be have an allocatable ultimate " + "component in assignment at %L", &lhs->where); + return false; + } + gfc_check_assign (lhs, rhs, 1); return false; } @@ -8096,7 +8810,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) gfc_resolve_omp_do_blocks (code, ns); break; case EXEC_SELECT_TYPE: - gfc_current_ns = code->ext.ns; + gfc_current_ns = code->ext.block.ns; gfc_resolve_blocks (code->block, gfc_current_ns); gfc_current_ns = ns; break; @@ -8260,7 +8974,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) break; case EXEC_BLOCK: - gfc_resolve (code->ext.ns); + resolve_block_construct (code); break; case EXEC_DO: @@ -8404,10 +9118,17 @@ resolve_code (gfc_code *code, gfc_namespace *ns) static void resolve_values (gfc_symbol *sym) { + gfc_try t; + if (sym->value == NULL) return; - if (gfc_resolve_expr (sym->value) == FAILURE) + if (sym->value->expr_type == EXPR_STRUCTURE) + t= resolve_structure_cons (sym->value, 1); + else + t = gfc_resolve_expr (sym->value); + + if (t == FAILURE) return; gfc_check_assign_symbol (sym, sym->value); @@ -8659,7 +9380,8 @@ resolve_charlen (gfc_charlen *cl) gfc_warning_now ("CHARACTER variable at %L has negative length %d," " the length has been set to zero", &cl->length->where, i); - gfc_replace_expr (cl->length, gfc_int_expr (0)); + gfc_replace_expr (cl->length, + gfc_get_int_expr (gfc_default_integer_kind, NULL, 0)); } /* Check that the character length is not too large. */ @@ -8691,13 +9413,12 @@ is_non_constant_shape_array (gfc_symbol *sym) /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that has not been simplified; parameter array references. Do the simplification now. */ - for (i = 0; i < sym->as->rank; i++) + for (i = 0; i < sym->as->rank + sym->as->corank; i++) { e = sym->as->lower[i]; if (e && (resolve_index_expr (e) == FAILURE || !gfc_is_constant_expr (e))) not_constant = true; - e = sym->as->upper[i]; if (e && (resolve_index_expr (e) == FAILURE || !gfc_is_constant_expr (e))) @@ -8761,10 +9482,11 @@ apply_default_init (gfc_symbol *sym) if (sym->ts.type == BT_DERIVED && sym->ts.u.derived) init = gfc_default_initializer (&sym->ts); - if (init == NULL) + if (init == NULL && sym->ts.type != BT_CLASS) return; build_init_assign (sym, init); + sym->attr.referenced = 1; } /* Build an initializer for a local integer, real, complex, logical, or @@ -8792,12 +9514,9 @@ build_default_init_expr (gfc_symbol *sym) return NULL; /* Now we'll try to build an initializer expression. */ - init_expr = gfc_get_expr (); - init_expr->expr_type = EXPR_CONSTANT; - init_expr->ts.type = sym->ts.type; - init_expr->ts.kind = sym->ts.kind; - init_expr->where = sym->declared_at; - + init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind, + &sym->declared_at); + /* We will only initialize integers, reals, complex, logicals, and characters, and only if the corresponding command-line flags were set. Otherwise, we free init_expr and return null. */ @@ -8805,7 +9524,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 { @@ -8815,7 +9534,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: @@ -8845,7 +9563,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: @@ -8976,18 +9693,43 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) sym->name, &sym->declared_at); return FAILURE; } - } else { if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer - && !sym->attr.dummy && sym->ts.type != BT_CLASS) + && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc) { gfc_error ("Array '%s' at %L cannot have a deferred shape", sym->name, &sym->declared_at); return FAILURE; } } + + /* Constraints on polymorphic variables. */ + if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym)) + { + /* F03:C502. */ + 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, + &sym->declared_at); + return FAILURE; + } + + /* F03:C509. */ + /* Assume that use associated symbols were checked in the module ns. + Class-variables that are associate-names are also something special + and excepted from the test. */ + if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc) + { + gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable " + "or pointer", sym->name, &sym->declared_at); + return FAILURE; + } + } + return SUCCESS; } @@ -9026,40 +9768,19 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) or POINTER attribute, the object shall have the SAVE attribute." The check for initializers is performed with - has_default_initializer because gfc_default_initializer generates + gfc_has_default_initializer because gfc_default_initializer generates a hidden default for allocatable components. */ if (!(sym->value || no_init_flag) && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE && !sym->ns->save_all && !sym->attr.save && !sym->attr.pointer && !sym->attr.allocatable - && has_default_initializer (sym->ts.u.derived) + && gfc_has_default_initializer (sym->ts.u.derived) && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for " "module variable '%s' at %L, needed due to " "the default initialization", sym->name, &sym->declared_at) == FAILURE) return FAILURE; - if (sym->ts.type == BT_CLASS) - { - /* C502. */ - if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived)) - { - gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", - sym->ts.u.derived->components->ts.u.derived->name, - sym->name, &sym->declared_at); - return FAILURE; - } - - /* C509. */ - /* Assume that use associated symbols were checked in the module ns. */ - if (!sym->attr.class_ok && !sym->attr.use_assoc) - { - gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable " - "or pointer", sym->name, &sym->declared_at); - return FAILURE; - } - } - /* Assign default initializer. */ if (!(sym->value || sym->attr.pointer || sym->attr.allocatable) && (!no_init_flag || sym->attr.intent == INTENT_OUT)) @@ -9119,7 +9840,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) return FAILURE; } - if (e && sym->attr.save && !gfc_is_constant_expr (e)) + if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e)) { gfc_error (auto_save_msg, sym->name, &sym->declared_at); return FAILURE; @@ -9147,7 +9868,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy || sym->attr.intrinsic || sym->attr.result) no_init_flag = 1; - else if (sym->attr.dimension && !sym->attr.pointer + else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer && is_non_constant_shape_array (sym)) { no_init_flag = automatic_flag = 1; @@ -9879,7 +10600,7 @@ resolve_tb_generic_targets (gfc_symbol* super_type, target_name = target->specific_st->name; /* Defined for this type directly. */ - if (target->specific_st->n.tb) + if (target->specific_st->n.tb && !target->specific_st->n.tb->error) { target->specific = target->specific_st->n.tb; goto specific_found; @@ -10230,7 +10951,7 @@ resolve_typebound_procedure (gfc_symtree* stree) goto error; } - if (me_arg->ts.u.derived->components->ts.u.derived + if (CLASS_DATA (me_arg)->ts.u.derived != resolve_bindings_derived) { gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" @@ -10240,20 +10961,19 @@ resolve_typebound_procedure (gfc_symtree* stree) } gcc_assert (me_arg->ts.type == BT_CLASS); - if (me_arg->ts.u.derived->components->as - && me_arg->ts.u.derived->components->as->rank > 0) + if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0) { gfc_error ("Passed-object dummy argument of '%s' at %L must be" " scalar", proc->name, &where); goto error; } - if (me_arg->ts.u.derived->components->attr.allocatable) + if (CLASS_DATA (me_arg)->attr.allocatable) { gfc_error ("Passed-object dummy argument of '%s' at %L must not" " be ALLOCATABLE", proc->name, &where); goto error; } - if (me_arg->ts.u.derived->components->attr.class_pointer) + if (CLASS_DATA (me_arg)->attr.class_pointer) { gfc_error ("Passed-object dummy argument of '%s' at %L must not" " be POINTER", proc->name, &where); @@ -10304,6 +11024,7 @@ error: stree->n.tb->error = 1; } + static gfc_try resolve_typebound_procedures (gfc_symbol* derived) { @@ -10315,6 +11036,9 @@ resolve_typebound_procedures (gfc_symbol* derived) resolve_bindings_derived = derived; resolve_bindings_result = SUCCESS; + /* Make sure the vtab has been generated. */ + gfc_find_derived_vtab (derived); + if (derived->f2k_derived->tb_sym_root) gfc_traverse_symtree (derived->f2k_derived->tb_sym_root, &resolve_typebound_procedure); @@ -10374,7 +11098,9 @@ ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st) { gfc_symtree* overriding; overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL); - gcc_assert (overriding && overriding->n.tb); + if (!overriding) + return FAILURE; + gcc_assert (overriding->n.tb); if (overriding->n.tb->deferred) { gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because" @@ -10397,7 +11123,10 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) This is not the most efficient way to do this, but it should be ok and is clearer than something sophisticated. */ - gcc_assert (ancestor && ancestor->attr.abstract && !sub->attr.abstract); + gcc_assert (ancestor && !sub->attr.abstract); + + if (!ancestor->attr.abstract) + return SUCCESS; /* Walk bindings of this ancestor. */ if (ancestor->f2k_derived) @@ -10417,9 +11146,6 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) } -static void resolve_symbol (gfc_symbol *sym); - - /* Resolve the components of a derived type. */ static gfc_try @@ -10427,9 +11153,30 @@ resolve_fl_derived (gfc_symbol *sym) { gfc_symbol* super_type; gfc_component *c; - int i; super_type = gfc_get_derived_super_type (sym); + + if (sym->attr.is_class && sym->ts.u.derived == NULL) + { + /* Fix up incomplete CLASS symbols. */ + gfc_component *data = gfc_find_component (sym, "$data", true, true); + 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); + gcc_assert (vtab); + vptr->ts.u.derived = vtab->ts.u.derived; + } + } + + /* F2008, C432. */ + if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp) + { + gfc_error ("As extending type '%s' at %L has a coarray component, " + "parent type '%s' shall also have one", sym->name, + &sym->declared_at, super_type->name); + return FAILURE; + } /* Ensure the extended type gets resolved before we do. */ if (super_type && resolve_fl_derived (super_type) == FAILURE) @@ -10445,9 +11192,46 @@ resolve_fl_derived (gfc_symbol *sym) for (c = sym->components; c != NULL; c = c->next) { + /* F2008, C442. */ + if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */ + && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED))) + { + gfc_error ("Coarray component '%s' at %L must be allocatable with " + "deferred shape", c->name, &c->loc); + return FAILURE; + } + + /* F2008, C443. */ + if (c->attr.codimension && c->ts.type == BT_DERIVED + && c->ts.u.derived->ts.is_iso_c) + { + gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " + "shall not be a coarray", c->name, &c->loc); + return FAILURE; + } + + /* F2008, C444. */ + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp + && (c->attr.codimension || c->attr.pointer || c->attr.dimension + || c->attr.allocatable)) + { + gfc_error ("Component '%s' at %L with coarray component " + "shall be a nonpointer, nonallocatable scalar", + c->name, &c->loc); + return FAILURE; + } + + /* F2008, C448. */ + if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer)) + { + gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but " + "is not an array pointer", c->name, &c->loc); + return FAILURE; + } + if (c->attr.proc_pointer && c->ts.interface) { - if (c->ts.interface->attr.procedure) + if (c->ts.interface->attr.procedure && !sym->attr.vtype) gfc_error ("Interface '%s', used by procedure pointer component " "'%s' at %L, is declared in a later PROCEDURE statement", c->ts.interface->name, c->name, &c->loc); @@ -10503,11 +11287,15 @@ resolve_fl_derived (gfc_symbol *sym) /* Copy char length. */ if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) { - c->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); - gfc_expr_replace_comp (c->ts.u.cl->length, c); + gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); + gfc_expr_replace_comp (cl->length, c); + if (cl->length && !cl->resolved + && gfc_resolve_expr (cl->length) == FAILURE) + return FAILURE; + c->ts.u.cl = cl; } } - else if (c->ts.interface->name[0] != '\0') + else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0') { gfc_error ("Interface '%s' of procedure pointer component " "'%s' at %L must be explicit", c->ts.interface->name, @@ -10523,7 +11311,8 @@ resolve_fl_derived (gfc_symbol *sym) } /* Procedure pointer components: Check PASS arg. */ - if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0) + if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0 + && !sym->attr.vtype) { gfc_symbol* me_arg; @@ -10576,7 +11365,7 @@ resolve_fl_derived (gfc_symbol *sym) if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS) || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym) || (me_arg->ts.type == BT_CLASS - && me_arg->ts.u.derived->components->ts.u.derived != sym)) + && CLASS_DATA (me_arg)->ts.u.derived != sym)) { gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" " the derived type '%s'", me_arg->name, c->name, @@ -10620,7 +11409,7 @@ resolve_fl_derived (gfc_symbol *sym) } /* Check type-spec if this is not the parent-type component. */ - if ((!sym->attr.extension || c != sym->components) + if ((!sym->attr.extension || c != sym->components) && !sym->attr.vtype && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE) return FAILURE; @@ -10632,7 +11421,7 @@ resolve_fl_derived (gfc_symbol *sym) /* If this type is an extension, see if this component has the same name as an inherited type-bound procedure. */ - if (super_type + if (super_type && !sym->attr.is_class && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) { gfc_error ("Component '%s' of '%s' at %L has the same name as an" @@ -10679,8 +11468,8 @@ resolve_fl_derived (gfc_symbol *sym) } } - if (c->ts.type == BT_DERIVED && c->attr.pointer - && c->ts.u.derived->components == NULL + if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype + && c->attr.pointer && c->ts.u.derived->components == NULL && !c->ts.u.derived->attr.zero_comp) { gfc_error ("The pointer component '%s' of '%s' at %L is a type " @@ -10689,10 +11478,20 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } + 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) + { + gfc_error ("The pointer component '%s' of '%s' at %L is a type " + "that has not been declared", c->name, sym->name, + &c->loc); + return FAILURE; + } + /* C437. */ if (c->ts.type == BT_CLASS - && !(c->ts.u.derived->components->attr.pointer - || c->ts.u.derived->components->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); @@ -10709,25 +11508,10 @@ resolve_fl_derived (gfc_symbol *sym) && sym != c->ts.u.derived) add_dt_to_dt_list (c->ts.u.derived); - if (c->attr.pointer || c->attr.proc_pointer || c->attr.allocatable - || c->as == NULL) - continue; - - for (i = 0; i < c->as->rank; i++) - { - if (c->as->lower[i] == NULL - || (resolve_index_expr (c->as->lower[i]) == FAILURE) - || !gfc_is_constant_expr (c->as->lower[i]) - || c->as->upper[i] == NULL - || (resolve_index_expr (c->as->upper[i]) == FAILURE) - || !gfc_is_constant_expr (c->as->upper[i])) - { - gfc_error ("Component '%s' of '%s' at %L must have " - "constant array bounds", - c->name, sym->name, &c->loc); - return FAILURE; - } - } + if (gfc_resolve_array_spec (c->as, !(c->attr.pointer + || c->attr.proc_pointer + || c->attr.allocatable)) == FAILURE) + return FAILURE; } /* Resolve the type-bound procedures. */ @@ -10741,6 +11525,7 @@ resolve_fl_derived (gfc_symbol *sym) /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that all DEFERRED bindings are overridden. */ if (super_type && super_type->attr.abstract && !sym->attr.abstract + && !sym->attr.is_class && ensure_not_abstract (sym, super_type) == FAILURE) return FAILURE; @@ -10757,6 +11542,46 @@ resolve_fl_namelist (gfc_symbol *sym) gfc_namelist *nl; gfc_symbol *nlsym; + for (nl = sym->namelist; nl; nl = nl->next) + { + /* Reject namelist arrays of assumed shape. */ + if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE + && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' " + "must not have assumed shape in namelist " + "'%s' at %L", nl->sym->name, sym->name, + &sym->declared_at) == FAILURE) + return FAILURE; + + /* Reject namelist arrays that are not constant shape. */ + if (is_non_constant_shape_array (nl->sym)) + { + gfc_error ("NAMELIST array object '%s' must have constant " + "shape in namelist '%s' at %L", nl->sym->name, + sym->name, &sym->declared_at); + return FAILURE; + } + + /* Namelist objects cannot have allocatable or pointer components. */ + if (nl->sym->ts.type != BT_DERIVED) + continue; + + if (nl->sym->ts.u.derived->attr.alloc_comp) + { + gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot " + "have ALLOCATABLE components", + nl->sym->name, sym->name, &sym->declared_at); + return FAILURE; + } + + if (nl->sym->ts.u.derived->attr.pointer_comp) + { + gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot " + "have POINTER components", + nl->sym->name, sym->name, &sym->declared_at); + return FAILURE; + } + } + /* Reject PRIVATE objects in a PUBLIC namelist. */ if (gfc_check_access(sym->attr.access, sym->ns->default_access)) { @@ -10798,46 +11623,6 @@ resolve_fl_namelist (gfc_symbol *sym) } } - for (nl = sym->namelist; nl; nl = nl->next) - { - /* Reject namelist arrays of assumed shape. */ - if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE - && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' " - "must not have assumed shape in namelist " - "'%s' at %L", nl->sym->name, sym->name, - &sym->declared_at) == FAILURE) - return FAILURE; - - /* Reject namelist arrays that are not constant shape. */ - if (is_non_constant_shape_array (nl->sym)) - { - gfc_error ("NAMELIST array object '%s' must have constant " - "shape in namelist '%s' at %L", nl->sym->name, - sym->name, &sym->declared_at); - return FAILURE; - } - - /* Namelist objects cannot have allocatable or pointer components. */ - if (nl->sym->ts.type != BT_DERIVED) - continue; - - if (nl->sym->ts.u.derived->attr.alloc_comp) - { - gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot " - "have ALLOCATABLE components", - nl->sym->name, sym->name, &sym->declared_at); - return FAILURE; - } - - if (nl->sym->ts.u.derived->attr.pointer_comp) - { - gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot " - "have POINTER components", - nl->sym->name, sym->name, &sym->declared_at); - return FAILURE; - } - } - /* 14.1.2 A module or internal procedure represent local entities of the same type as a namelist member and so are not allowed. */ @@ -10920,6 +11705,11 @@ resolve_symbol (gfc_symbol *sym) gfc_namespace *ns; gfc_component *c; + /* Avoid double resolution of function result symbols. */ + if ((sym->result || sym->attr.result) && !sym->attr.dummy + && (sym->ns != gfc_current_ns)) + return; + if (sym->attr.flavor == FL_UNKNOWN) { @@ -10933,9 +11723,7 @@ resolve_symbol (gfc_symbol *sym) { this_symtree = gfc_find_symtree (gfc_current_ns->sym_root, sym->name); - sym->refs--; - if (!sym->refs) - gfc_free_symbol (sym); + gfc_release_symbol (sym); symtree->n.sym->refs++; this_symtree->n.sym = symtree->n.sym; return; @@ -10958,73 +11746,33 @@ resolve_symbol (gfc_symbol *sym) gfc_add_function (&sym->attr, sym->name, &sym->declared_at); if (sym->attr.procedure && sym->ts.interface - && sym->attr.if_source != IFSRC_DECL) + && sym->attr.if_source != IFSRC_DECL + && resolve_procedure_interface (sym) == FAILURE) + return; + + if (sym->attr.is_protected && !sym->attr.proc_pointer + && (sym->attr.procedure || sym->attr.external)) { - if (sym->ts.interface == sym) - { - gfc_error ("PROCEDURE '%s' at %L may not be used as its own " - "interface", sym->name, &sym->declared_at); - return; - } - if (sym->ts.interface->attr.procedure) - { - gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared" - " in a later PROCEDURE statement", sym->ts.interface->name, - sym->name,&sym->declared_at); - return; - } + if (sym->attr.external) + gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute " + "at %L", &sym->declared_at); + else + gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute " + "at %L", &sym->declared_at); - /* Get the attributes from the interface (now resolved). */ - if (sym->ts.interface->attr.if_source - || sym->ts.interface->attr.intrinsic) - { - gfc_symbol *ifc = sym->ts.interface; - resolve_symbol (ifc); - - if (ifc->attr.intrinsic) - resolve_intrinsic (ifc, &ifc->declared_at); - - if (ifc->result) - sym->ts = ifc->result->ts; - else - sym->ts = ifc->ts; - sym->ts.interface = ifc; - sym->attr.function = ifc->attr.function; - sym->attr.subroutine = ifc->attr.subroutine; - gfc_copy_formal_args (sym, ifc); - - sym->attr.allocatable = ifc->attr.allocatable; - sym->attr.pointer = ifc->attr.pointer; - sym->attr.pure = ifc->attr.pure; - sym->attr.elemental = ifc->attr.elemental; - sym->attr.dimension = ifc->attr.dimension; - sym->attr.recursive = ifc->attr.recursive; - sym->attr.always_explicit = ifc->attr.always_explicit; - sym->attr.ext_attr |= ifc->attr.ext_attr; - /* Copy array spec. */ - sym->as = gfc_copy_array_spec (ifc->as); - if (sym->as) - { - int i; - for (i = 0; i < sym->as->rank; i++) - { - gfc_expr_replace_symbols (sym->as->lower[i], sym); - gfc_expr_replace_symbols (sym->as->upper[i], sym); - } - } - /* Copy char length. */ - if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) - { - sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); - gfc_expr_replace_symbols (sym->ts.u.cl->length, sym); - } - } - else if (sym->ts.interface->name[0] != '\0') - { - gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit", - sym->ts.interface->name, sym->name, &sym->declared_at); - return; - } + return; + } + + + /* F2008, C530. */ + if (sym->attr.contiguous + && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE + && !sym->attr.pointer))) + { + gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an " + "array pointer or an assumed-shape array", sym->name, + &sym->declared_at); + return; } if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE) @@ -11037,7 +11785,6 @@ resolve_symbol (gfc_symbol *sym) can. */ mp_flag = (sym->result != NULL && sym->result != sym); - /* Make sure that the intrinsic is consistent with its internal representation. This needs to be done before assigning a default type to avoid spurious warnings. */ @@ -11045,6 +11792,10 @@ resolve_symbol (gfc_symbol *sym) && resolve_intrinsic (sym, &sym->declared_at) == FAILURE) return; + /* Resolve associate names. */ + if (sym->assoc) + resolve_assoc_var (sym, true); + /* Assign default type to symbols that need one and don't have one. */ if (sym->ts.type == BT_UNKNOWN) { @@ -11074,26 +11825,31 @@ resolve_symbol (gfc_symbol *sym) sym->attr.dimension = sym->result->attr.dimension; sym->attr.pointer = sym->result->attr.pointer; sym->attr.allocatable = sym->result->attr.allocatable; + sym->attr.contiguous = sym->result->attr.contiguous; } } } } /* Assumed size arrays and assumed shape arrays must be dummy - arguments. */ + arguments. Array-spec's of implied-shape should have been resolved to + AS_EXPLICIT already. */ - if (sym->as != NULL - && ((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed) - || sym->as->type == AS_ASSUMED_SHAPE) - && sym->attr.dummy == 0) + if (sym->as) { - if (sym->as->type == AS_ASSUMED_SIZE) - gfc_error ("Assumed size array at %L must be a dummy argument", - &sym->declared_at); - else - gfc_error ("Assumed shape array at %L must be a dummy argument", - &sym->declared_at); - return; + gcc_assert (sym->as->type != AS_IMPLIED_SHAPE); + if (((sym->as->type == AS_ASSUMED_SIZE && !sym->as->cp_was_assumed) + || sym->as->type == AS_ASSUMED_SHAPE) + && sym->attr.dummy == 0) + { + if (sym->as->type == AS_ASSUMED_SIZE) + gfc_error ("Assumed size array at %L must be a dummy argument", + &sym->declared_at); + else + gfc_error ("Assumed shape array at %L must be a dummy argument", + &sym->declared_at); + return; + } } /* Make sure symbols with known intent or optional are really dummy @@ -11275,6 +12031,62 @@ resolve_symbol (gfc_symbol *sym) } } + /* F2008, C526. */ + if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) + || sym->attr.codimension) + && sym->attr.result) + gfc_error ("Function result '%s' at %L shall not be a coarray or have " + "a coarray component", sym->name, &sym->declared_at); + + /* F2008, C524. */ + if (sym->attr.codimension && sym->ts.type == BT_DERIVED + && sym->ts.u.derived->ts.is_iso_c) + gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " + "shall not be a coarray", sym->name, &sym->declared_at); + + /* F2008, C525. */ + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp + && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension + || sym->attr.allocatable)) + gfc_error ("Variable '%s' at %L with coarray component " + "shall be a nonpointer, nonallocatable scalar", + sym->name, &sym->declared_at); + + /* F2008, C526. The function-result case was handled above. */ + if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) + || sym->attr.codimension) + && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save + || sym->ns->proc_name->attr.flavor == FL_MODULE + || sym->ns->proc_name->attr.is_main_program + || sym->attr.function || sym->attr.result || sym->attr.use_assoc)) + gfc_error ("Variable '%s' at %L is a coarray or has a coarray " + "component and is not ALLOCATABLE, SAVE nor a " + "dummy argument", sym->name, &sym->declared_at); + /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */ + else if (sym->attr.codimension && !sym->attr.allocatable + && sym->as && sym->as->cotype == AS_DEFERRED) + gfc_error ("Coarray variable '%s' at %L shall not have codimensions with " + "deferred shape", sym->name, &sym->declared_at); + else if (sym->attr.codimension && sym->attr.allocatable + && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED)) + gfc_error ("Allocatable coarray variable '%s' at %L must have " + "deferred shape", sym->name, &sym->declared_at); + + + /* F2008, C541. */ + if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) + || (sym->attr.codimension && sym->attr.allocatable)) + && sym->attr.dummy && sym->attr.intent == INTENT_OUT) + gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an " + "allocatable coarray or have coarray components", + sym->name, &sym->declared_at); + + if (sym->attr.codimension && sym->attr.dummy + && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c) + gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) " + "procedure '%s'", sym->name, &sym->declared_at, + sym->ns->proc_name->name); + switch (sym->attr.flavor) { case FL_VARIABLE: @@ -11347,7 +12159,6 @@ resolve_symbol (gfc_symbol *sym) described in 14.7.5, to those variables that have not already been assigned one. */ if (sym->ts.type == BT_DERIVED - && sym->attr.referenced && sym->ns == gfc_current_ns && !sym->value && !sym->attr.allocatable @@ -11357,11 +12168,18 @@ resolve_symbol (gfc_symbol *sym) if ((!a->save && !a->dummy && !a->pointer && !a->in_common && !a->use_assoc + && (a->referenced || a->result) && !(a->function && sym != sym->result)) || (a->dummy && a->intent == INTENT_OUT && !a->pointer)) apply_default_init (sym); } + if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns + && sym->attr.dummy && sym->attr.intent == INTENT_OUT + && !CLASS_DATA (sym)->attr.class_pointer + && !CLASS_DATA (sym)->attr.allocatable) + apply_default_init (sym); + /* If this symbol has a type-spec, check it. */ if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)) @@ -11447,6 +12265,13 @@ check_data_variable (gfc_data_variable *var, locus *where) if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) has_pointer = 1; + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + { + gfc_error ("DATA element '%s' at %L cannot have a coindex", + sym->name, where); + return FAILURE; + } + if (has_pointer && ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL) @@ -11543,11 +12368,14 @@ check_data_variable (gfc_data_variable *var, locus *where) mpz_set_ui (size, 0); } - gfc_assign_data_value_range (var->expr, values.vnode->expr, - offset, range); + t = gfc_assign_data_value_range (var->expr, values.vnode->expr, + offset, range); mpz_add (offset, offset, range); mpz_clear (range); + + if (t == FAILURE) + break; } /* Assign initial value to symbol. */ @@ -11596,6 +12424,7 @@ traverse_data_list (gfc_data_variable *var, locus *where) gfc_try retval = SUCCESS; mpz_init (frame.value); + mpz_init (trip); start = gfc_copy_expr (var->iter.start); end = gfc_copy_expr (var->iter.end); @@ -11604,26 +12433,29 @@ traverse_data_list (gfc_data_variable *var, locus *where) if (gfc_simplify_expr (start, 1) == FAILURE || start->expr_type != EXPR_CONSTANT) { - gfc_error ("iterator start at %L does not simplify", &start->where); + gfc_error ("start of implied-do loop at %L could not be " + "simplified to a constant value", &start->where); retval = FAILURE; goto cleanup; } if (gfc_simplify_expr (end, 1) == FAILURE || end->expr_type != EXPR_CONSTANT) { - gfc_error ("iterator end at %L does not simplify", &end->where); + gfc_error ("end of implied-do loop at %L could not be " + "simplified to a constant value", &start->where); retval = FAILURE; goto cleanup; } if (gfc_simplify_expr (step, 1) == FAILURE || step->expr_type != EXPR_CONSTANT) { - gfc_error ("iterator step at %L does not simplify", &step->where); + gfc_error ("step of implied-do loop at %L could not be " + "simplified to a constant value", &start->where); retval = FAILURE; goto cleanup; } - mpz_init_set (trip, end->value.integer); + mpz_set (trip, end->value.integer); mpz_sub (trip, trip, start->value.integer); mpz_add (trip, trip, step->value.integer); @@ -11639,7 +12471,6 @@ traverse_data_list (gfc_data_variable *var, locus *where) { if (traverse_data_var (var->list, where) == FAILURE) { - mpz_clear (trip); retval = FAILURE; goto cleanup; } @@ -11648,7 +12479,6 @@ traverse_data_list (gfc_data_variable *var, locus *where) if (gfc_simplify_expr (e, 1) == FAILURE) { gfc_free_expr (e); - mpz_clear (trip); retval = FAILURE; goto cleanup; } @@ -11658,9 +12488,9 @@ traverse_data_list (gfc_data_variable *var, locus *where) mpz_sub_ui (trip, trip, 1); } - mpz_clear (trip); cleanup: mpz_clear (frame.value); + mpz_clear (trip); gfc_free_expr (start); gfc_free_expr (end); @@ -11809,7 +12639,7 @@ gfc_pure (gfc_symbol *sym) if (sym == NULL) return 0; attr = sym->attr; - if (attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental)) + if (attr.flavor == FL_PROCEDURE && attr.pure) return 1; } return 0; @@ -11817,7 +12647,7 @@ gfc_pure (gfc_symbol *sym) attr = sym->attr; - return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental); + return attr.flavor == FL_PROCEDURE && attr.pure; } @@ -11958,7 +12788,7 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) return FAILURE; } - if (sym->attr.in_common && has_default_initializer (sym->ts.u.derived)) + if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived)) { gfc_error ("Derived type variable '%s' at %L with default " "initialization cannot be in EQUIVALENCE with a variable " @@ -12062,7 +12892,8 @@ resolve_equivalence (gfc_equiv *eq) { ref->type = REF_SUBSTRING; if (start == NULL) - start = gfc_int_expr (1); + start = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1); ref->u.ss.start = start; if (end == NULL && e->ts.u.cl) end = gfc_copy_expr (e->ts.u.cl->length); @@ -12513,4 +13344,6 @@ gfc_resolve (gfc_namespace *ns) gfc_current_ns = old_ns; cs_base = old_cs_base; ns->resolved = 1; + + gfc_run_passes (ns); } diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c index 711042ddcb2..744abeb26e3 100644 --- a/gcc/fortran/scanner.c +++ b/gcc/fortran/scanner.c @@ -44,7 +44,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "gfortran.h" -#include "toplev.h" +#include "toplev.h" /* For set_src_pwd. */ #include "debug.h" #include "flags.h" #include "cpp.h" @@ -390,7 +390,8 @@ gfc_release_include_path (void) static FILE * -open_included_file (const char *name, gfc_directorylist *list, bool module) +open_included_file (const char *name, gfc_directorylist *list, + bool module, bool system) { char *fullname; gfc_directorylist *p; @@ -407,7 +408,12 @@ open_included_file (const char *name, gfc_directorylist *list, bool module) f = gfc_open_file (fullname); if (f != NULL) - return f; + { + if (gfc_cpp_makedep ()) + gfc_cpp_add_dep (fullname, system); + + return f; + } } return NULL; @@ -421,28 +427,37 @@ open_included_file (const char *name, gfc_directorylist *list, bool module) FILE * gfc_open_included_file (const char *name, bool include_cwd, bool module) { - FILE *f; - - if (IS_ABSOLUTE_PATH (name)) - return gfc_open_file (name); + FILE *f = NULL; - if (include_cwd) + if (IS_ABSOLUTE_PATH (name) || include_cwd) { f = gfc_open_file (name); - if (f != NULL) - return f; + if (f && gfc_cpp_makedep ()) + gfc_cpp_add_dep (name, false); } - return open_included_file (name, include_dirs, module); + if (!f) + f = open_included_file (name, include_dirs, module, false); + + return f; } FILE * gfc_open_intrinsic_module (const char *name) { + FILE *f = NULL; + if (IS_ABSOLUTE_PATH (name)) - return gfc_open_file (name); + { + f = gfc_open_file (name); + if (f && gfc_cpp_makedep ()) + gfc_cpp_add_dep (name, true); + } + + if (!f) + f = open_included_file (name, intrinsic_modules_dirs, true, true); - return open_included_file (name, intrinsic_modules_dirs, true); + return f; } @@ -1029,6 +1044,17 @@ restart: goto done; } + /* Check to see if the continuation line was truncated. */ + if (gfc_option.warn_line_truncation && gfc_current_locus.lb != NULL + && gfc_current_locus.lb->truncated) + { + int maxlen = gfc_option.free_line_length; + gfc_current_locus.lb->truncated = 0; + gfc_current_locus.nextc += maxlen; + gfc_warning_now ("Line truncated at %L", &gfc_current_locus); + gfc_current_locus.nextc -= maxlen; + } + if (c != '&') goto done; @@ -1080,17 +1106,6 @@ restart: } } - /* Check to see if the continuation line was truncated. */ - if (gfc_option.warn_line_truncation && gfc_current_locus.lb != NULL - && gfc_current_locus.lb->truncated) - { - int maxlen = gfc_option.free_line_length; - gfc_current_locus.lb->truncated = 0; - gfc_current_locus.nextc += maxlen; - gfc_warning_now ("Line truncated at %L", &gfc_current_locus); - gfc_current_locus.nextc -= maxlen; - } - /* Now find where it continues. First eat any comment lines. */ openmp_cond_flag = skip_free_comments (); @@ -1405,7 +1420,7 @@ load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char) static int linenum = 0, current_line = 1; int c, maxlen, i, preprocessor_flag, buflen = *pbuflen; int trunc_flag = 0, seen_comment = 0; - int seen_printable = 0, seen_ampersand = 0; + int seen_printable = 0, seen_ampersand = 0, quoted = ' '; gfc_char_t *buffer; bool found_tab = false; @@ -1487,6 +1502,18 @@ load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char) && (c == '*' || c == 'c' || c == 'd')) seen_comment = 1; + if (quoted == ' ') + { + if (c == '\'' || c == '"') + quoted = c; + } + else if (c == quoted) + quoted = ' '; + + /* Is this a free-form comment? */ + if (c == '!' && quoted == ' ') + seen_comment = 1; + /* Vendor extension: "<tab>1" marks a continuation line. */ if (found_tab) { @@ -1535,17 +1562,34 @@ load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char) } else if (i >= maxlen) { + bool trunc_warn = true; + + /* Enhancement, if the very next non-space character is an ampersand + or comment that we would otherwise warn about, don't mark as + truncated. */ + /* Truncate the rest of the line. */ for (;;) { c = getc (input); - if (c == '\r') + if (c == '\r' || c == ' ') continue; if (c == '\n' || c == EOF) break; - trunc_flag = 1; + if (!trunc_warn && c != '!') + trunc_warn = true; + + if (trunc_warn && ((gfc_current_form == FORM_FIXED && c == '&') + || c == '!')) + trunc_warn = false; + + if (c == '!') + seen_comment = 1; + + if (trunc_warn && !seen_comment) + trunc_flag = 1; } c = '\n'; diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 50cd6da7591..a7b678f406a 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -26,10 +26,8 @@ along with GCC; see the file COPYING3. If not see #include "arith.h" #include "intrinsic.h" #include "target-memory.h" +#include "constructor.h" -/* Savely advance an array constructor by 'n' elements. - Mainly used by simplifiers of transformational intrinsics. */ -#define ADVANCE(ctor, n) do { int i; for (i = 0; i < n && ctor; ++i) ctor = ctor->next; } while (0) gfc_expr gfc_bad_expr; @@ -45,15 +43,12 @@ gfc_expr gfc_bad_expr; be a part of the new expression. NULL pointer indicating that no simplification was possible and - the original expression should remain intact. If the - simplification function sets the type and/or the function name - via the pointer gfc_simple_expression, then this type is - retained. + the original expression should remain intact. An expression pointer to gfc_bad_expr (a static placeholder) - indicating that some error has prevented simplification. For - example, sqrt(-1.0). The error is generated within the function - and should be propagated upwards + indicating that some error has prevented simplification. The + error is generated within the function and should be propagated + upwards By the time a simplification function gets control, it has been decided that the function call is really supposed to be the @@ -62,7 +57,8 @@ gfc_expr gfc_bad_expr; subroutine may have to look at the type of an argument as part of its processing. - Array arguments are never passed to these subroutines. + Array arguments are only passed to these subroutines that implement + the simplification of transformational intrinsics. The functions in this file don't have much comment with them, but everything is reasonably straight-forward. The Standard, chapter 13 @@ -77,6 +73,9 @@ range_check (gfc_expr *result, const char *name) if (result == NULL) return &gfc_bad_expr; + if (result->expr_type != EXPR_CONSTANT) + return result; + switch (gfc_range_check (result)) { case ARITH_OK: @@ -136,20 +135,6 @@ get_kind (bt type, gfc_expr *k, const char *name, int default_kind) } -/* Helper function to get an integer constant with a kind number given - by an integer constant expression. */ -static gfc_expr * -int_expr_with_kind (int i, gfc_expr *kind, const char *name) -{ - gfc_expr *res = gfc_int_expr (i); - res->ts.kind = get_kind (BT_INTEGER, kind, name, gfc_default_integer_kind); - if (res->ts.kind == -1) - return NULL; - else - return res; -} - - /* Converts an mpz_t signed variable into an unsigned one, assuming two's complement representations and a binary width of bitsize. The conversion is a no-op unless x is negative; otherwise, it can @@ -214,6 +199,27 @@ convert_mpz_to_signed (mpz_t x, int bitsize) } } + +/* In-place convert BOZ to REAL of the specified kind. */ + +static gfc_expr * +convert_boz (gfc_expr *x, int kind) +{ + if (x && x->ts.type == BT_INTEGER && x->is_boz) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_REAL; + ts.kind = kind; + + if (!gfc_convert_boz (x, &ts)) + return &gfc_bad_expr; + } + + return x; +} + + /* Test that the expression is an constant array. */ static bool @@ -227,7 +233,8 @@ is_constant_array_expr (gfc_expr *e) if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e)) return false; - for (c = e->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) if (c->expr->expr_type != EXPR_CONSTANT) return false; @@ -242,11 +249,11 @@ init_result_expr (gfc_expr *e, int init, gfc_expr *array) { if (e && e->expr_type == EXPR_ARRAY) { - gfc_constructor *ctor = e->value.constructor; + gfc_constructor *ctor = gfc_constructor_first (e->value.constructor); while (ctor) { init_result_expr (ctor->expr, init, array); - ctor = ctor->next; + ctor = gfc_constructor_next (ctor); } } else if (e && e->expr_type == EXPR_CONSTANT) @@ -324,18 +331,18 @@ init_result_expr (gfc_expr *e, int init, gfc_expr *array) /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul. */ static gfc_expr * -compute_dot_product (gfc_constructor *ctor_a, int stride_a, - gfc_constructor *ctor_b, int stride_b) +compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a, + gfc_expr *matrix_b, int stride_b, int offset_b) { - gfc_expr *result; - gfc_expr *a = ctor_a->expr, *b = ctor_b->expr; + gfc_expr *result, *a, *b; - gcc_assert (gfc_compare_types (&a->ts, &b->ts)); - - result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where); + result = gfc_get_constant_expr (matrix_a->ts.type, matrix_a->ts.kind, + &matrix_a->where); init_result_expr (result, 0, NULL); - while (ctor_a && ctor_b) + a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a); + b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b); + while (a && b) { /* Copying of expressions is required as operands are free'd by the gfc_arith routines. */ @@ -343,24 +350,27 @@ compute_dot_product (gfc_constructor *ctor_a, int stride_a, { case BT_LOGICAL: result = gfc_or (result, - gfc_and (gfc_copy_expr (ctor_a->expr), - gfc_copy_expr (ctor_b->expr))); + gfc_and (gfc_copy_expr (a), + gfc_copy_expr (b))); break; case BT_INTEGER: case BT_REAL: case BT_COMPLEX: result = gfc_add (result, - gfc_multiply (gfc_copy_expr (ctor_a->expr), - gfc_copy_expr (ctor_b->expr))); + gfc_multiply (gfc_copy_expr (a), + gfc_copy_expr (b))); break; default: gcc_unreachable(); } - ADVANCE (ctor_a, stride_a); - ADVANCE (ctor_b, stride_b); + offset_a += stride_a; + a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a); + + offset_b += stride_b; + b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b); } return result; @@ -378,9 +388,9 @@ transformational_result (gfc_expr *array, gfc_expr *dim, bt type, int i, nelem; if (!dim || array->rank == 1) - return gfc_constant_result (type, kind, where); + return gfc_get_constant_expr (type, kind, where); - result = gfc_start_constructor (type, kind, where); + result = gfc_get_array_expr (type, kind, where); result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim); result->rank = array->rank - 1; @@ -392,8 +402,9 @@ transformational_result (gfc_expr *array, gfc_expr *dim, bt type, for (i = 0; i < nelem; ++i) { - gfc_expr *e = gfc_constant_result (type, kind, where); - gfc_append_constructor (result, e); + gfc_constructor_append_expr (&result->value.constructor, + gfc_get_constant_expr (type, kind, where), + NULL); } return result; @@ -446,21 +457,21 @@ simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr * && !mask->value.logical) return result; - array_ctor = array->value.constructor; + array_ctor = gfc_constructor_first (array->value.constructor); mask_ctor = NULL; if (mask && mask->expr_type == EXPR_ARRAY) - mask_ctor = mask->value.constructor; + mask_ctor = gfc_constructor_first (mask->value.constructor); while (array_ctor) { a = array_ctor->expr; - array_ctor = array_ctor->next; + array_ctor = gfc_constructor_next (array_ctor); /* A constant MASK equals .TRUE. here and can be ignored. */ if (mask_ctor) { m = mask_ctor->expr; - mask_ctor = mask_ctor->next; + mask_ctor = gfc_constructor_next (mask_ctor); if (!m->value.logical) continue; } @@ -477,11 +488,12 @@ simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr * REAL, PARAMETER :: array(n, m) = ... REAL, PARAMETER :: s(n) = PROD(array, DIM=1) - where OP == gfc_multiply(). */ + where OP == gfc_multiply(). The result might be post processed using post_op. */ static gfc_expr * simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim, - gfc_expr *mask, transformational_op op) + gfc_expr *mask, transformational_op op, + transformational_op post_op) { mpz_t size; int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; @@ -505,22 +517,22 @@ simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *d arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize); - array_ctor = array->value.constructor; + array_ctor = gfc_constructor_first (array->value.constructor); mask_ctor = NULL; if (mask && mask->expr_type == EXPR_ARRAY) - mask_ctor = mask->value.constructor; + mask_ctor = gfc_constructor_first (mask->value.constructor); for (i = 0; i < arraysize; ++i) { arrayvec[i] = array_ctor->expr; - array_ctor = array_ctor->next; + array_ctor = gfc_constructor_next (array_ctor); if (mask_ctor) { if (!mask_ctor->expr->value.logical) arrayvec[i] = NULL; - mask_ctor = mask_ctor->next; + mask_ctor = gfc_constructor_next (mask_ctor); } } @@ -530,11 +542,11 @@ simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *d mpz_clear (size); resultvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize); - result_ctor = result->value.constructor; + result_ctor = gfc_constructor_first (result->value.constructor); for (i = 0; i < resultsize; ++i) { resultvec[i] = result_ctor->expr; - result_ctor = result_ctor->next; + result_ctor = gfc_constructor_next (result_ctor); } gfc_extract_int (dim, &dim_index); @@ -592,11 +604,14 @@ simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *d } /* Place updated expression in result constructor. */ - result_ctor = result->value.constructor; + result_ctor = gfc_constructor_first (result->value.constructor); for (i = 0; i < resultsize; ++i) { - result_ctor->expr = resultvec[i]; - result_ctor = result_ctor->next; + if (post_op) + result_ctor->expr = post_op (result_ctor->expr, resultvec[i]); + else + result_ctor->expr = resultvec[i]; + result_ctor = gfc_constructor_next (result_ctor); } gfc_free (arrayvec); @@ -605,6 +620,30 @@ simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *d } +static gfc_expr * +simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, + int init_val, transformational_op op) +{ + gfc_expr *result; + + if (!is_constant_array_expr (array) + || !gfc_is_constant_expr (dim)) + return NULL; + + if (mask + && !is_constant_array_expr (mask) + && mask->expr_type != EXPR_CONSTANT) + return NULL; + + result = transformational_result (array, dim, array->ts.type, + array->ts.kind, &array->where); + init_result_expr (result, init_val, NULL); + + return !dim || array->rank == 1 ? + simplify_transformation_to_scalar (result, array, mask, op) : + simplify_transformation_to_array (result, array, dim, mask, op, NULL); +} + /********************** Simplification functions *****************************/ @@ -618,36 +657,25 @@ gfc_simplify_abs (gfc_expr *e) switch (e->ts.type) { - case BT_INTEGER: - result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where); - - mpz_abs (result->value.integer, e->value.integer); - - result = range_check (result, "IABS"); - break; - - case BT_REAL: - result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); - - mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE); - - result = range_check (result, "ABS"); - break; - - case BT_COMPLEX: - result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); + case BT_INTEGER: + result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where); + mpz_abs (result->value.integer, e->value.integer); + return range_check (result, "IABS"); - gfc_set_model_kind (e->ts.kind); + case BT_REAL: + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE); + return range_check (result, "ABS"); - mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE); - result = range_check (result, "CABS"); - break; + case BT_COMPLEX: + gfc_set_model_kind (e->ts.kind); + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE); + return range_check (result, "CABS"); - default: - gfc_internal_error ("gfc_simplify_abs(): Bad type"); + default: + gfc_internal_error ("gfc_simplify_abs(): Bad type"); } - - return result; } @@ -697,11 +725,9 @@ simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii) return &gfc_bad_expr; } - result = gfc_constant_result (BT_CHARACTER, kind, &e->where); - result->value.character.string = gfc_get_wide_string (2); - result->value.character.length = 1; + result = gfc_get_character_expr (kind, &e->where, NULL, 1); result->value.character.string[0] = mpz_get_ui (e->value.integer); - result->value.character.string[1] = '\0'; /* For debugger */ + return result; } @@ -735,18 +761,19 @@ gfc_simplify_acos (gfc_expr *x) &x->where); return &gfc_bad_expr; } - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE); break; + case BT_COMPLEX: - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); break; + default: gfc_internal_error ("in gfc_simplify_acos(): Bad type"); } - return range_check (result, "ACOS"); } @@ -768,13 +795,15 @@ gfc_simplify_acosh (gfc_expr *x) return &gfc_bad_expr; } - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE); break; + case BT_COMPLEX: - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); break; + default: gfc_internal_error ("in gfc_simplify_acosh(): Bad type"); } @@ -794,11 +823,6 @@ gfc_simplify_adjustl (gfc_expr *e) len = e->value.character.length; - result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); - - result->value.character.length = len; - result->value.character.string = gfc_get_wide_string (len + 1); - for (count = 0, i = 0; i < len; ++i) { ch = e->value.character.string[i]; @@ -807,14 +831,10 @@ gfc_simplify_adjustl (gfc_expr *e) ++count; } + result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len); for (i = 0; i < len - count; ++i) result->value.character.string[i] = e->value.character.string[count + i]; - for (i = len - count; i < len; ++i) - result->value.character.string[i] = ' '; - - result->value.character.string[len] = '\0'; /* For debugger */ - return result; } @@ -831,11 +851,6 @@ gfc_simplify_adjustr (gfc_expr *e) len = e->value.character.length; - result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); - - result->value.character.length = len; - result->value.character.string = gfc_get_wide_string (len + 1); - for (count = 0, i = len - 1; i >= 0; --i) { ch = e->value.character.string[i]; @@ -844,14 +859,13 @@ gfc_simplify_adjustr (gfc_expr *e) ++count; } + result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len); for (i = 0; i < count; ++i) result->value.character.string[i] = ' '; for (i = count; i < len; ++i) result->value.character.string[i] = e->value.character.string[i - count]; - result->value.character.string[len] = '\0'; /* For debugger */ - return result; } @@ -864,7 +878,7 @@ gfc_simplify_aimag (gfc_expr *e) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE); return range_check (result, "AIMAG"); @@ -885,10 +899,10 @@ gfc_simplify_aint (gfc_expr *e, gfc_expr *k) return NULL; rtrunc = gfc_copy_expr (e); - mpfr_trunc (rtrunc->value.real, e->value.real); result = gfc_real2real (rtrunc, kind); + gfc_free_expr (rtrunc); return range_check (result, "AINT"); @@ -898,19 +912,7 @@ gfc_simplify_aint (gfc_expr *e, gfc_expr *k) gfc_expr * gfc_simplify_all (gfc_expr *mask, gfc_expr *dim) { - gfc_expr *result; - - if (!is_constant_array_expr (mask) - || !gfc_is_constant_expr (dim)) - return NULL; - - result = transformational_result (mask, dim, mask->ts.type, - mask->ts.kind, &mask->where); - init_result_expr (result, true, NULL); - - return !dim || mask->rank == 1 ? - simplify_transformation_to_scalar (result, mask, NULL, gfc_and) : - simplify_transformation_to_array (result, mask, dim, NULL, gfc_and); + return simplify_transformation (mask, dim, NULL, true, gfc_and); } @@ -923,10 +925,10 @@ gfc_simplify_dint (gfc_expr *e) return NULL; rtrunc = gfc_copy_expr (e); - mpfr_trunc (rtrunc->value.real, e->value.real); result = gfc_real2real (rtrunc, gfc_default_double_kind); + gfc_free_expr (rtrunc); return range_check (result, "DINT"); @@ -946,8 +948,7 @@ gfc_simplify_anint (gfc_expr *e, gfc_expr *k) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (e->ts.type, kind, &e->where); - + result = gfc_get_constant_expr (e->ts.type, kind, &e->where); mpfr_round (result->value.real, e->value.real); return range_check (result, "ANINT"); @@ -964,17 +965,20 @@ gfc_simplify_and (gfc_expr *x, gfc_expr *y) return NULL; kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - if (x->ts.type == BT_INTEGER) - { - result = gfc_constant_result (BT_INTEGER, kind, &x->where); - mpz_and (result->value.integer, x->value.integer, y->value.integer); - return range_check (result, "AND"); - } - else /* BT_LOGICAL */ + + switch (x->ts.type) { - result = gfc_constant_result (BT_LOGICAL, kind, &x->where); - result->value.logical = x->value.logical && y->value.logical; - return result; + case BT_INTEGER: + result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); + mpz_and (result->value.integer, x->value.integer, y->value.integer); + return range_check (result, "AND"); + + case BT_LOGICAL: + return gfc_get_logical_expr (kind, &x->where, + x->value.logical && y->value.logical); + + default: + gcc_unreachable (); } } @@ -982,19 +986,7 @@ gfc_simplify_and (gfc_expr *x, gfc_expr *y) gfc_expr * gfc_simplify_any (gfc_expr *mask, gfc_expr *dim) { - gfc_expr *result; - - if (!is_constant_array_expr (mask) - || !gfc_is_constant_expr (dim)) - return NULL; - - result = transformational_result (mask, dim, mask->ts.type, - mask->ts.kind, &mask->where); - init_result_expr (result, false, NULL); - - return !dim || mask->rank == 1 ? - simplify_transformation_to_scalar (result, mask, NULL, gfc_or) : - simplify_transformation_to_array (result, mask, dim, NULL, gfc_or); + return simplify_transformation (mask, dim, NULL, false, gfc_or); } @@ -1006,8 +998,7 @@ gfc_simplify_dnint (gfc_expr *e) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where); - + result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where); mpfr_round (result->value.real, e->value.real); return range_check (result, "DNINT"); @@ -1032,13 +1023,15 @@ gfc_simplify_asin (gfc_expr *x) &x->where); return &gfc_bad_expr; } - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE); break; + case BT_COMPLEX: - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); break; + default: gfc_internal_error ("in gfc_simplify_asin(): Bad type"); } @@ -1055,16 +1048,18 @@ gfc_simplify_asinh (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + switch (x->ts.type) { case BT_REAL: - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE); break; + case BT_COMPLEX: - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); break; + default: gfc_internal_error ("in gfc_simplify_asinh(): Bad type"); } @@ -1080,17 +1075,19 @@ gfc_simplify_atan (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + switch (x->ts.type) { case BT_REAL: - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE); break; + case BT_COMPLEX: - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); break; + default: gfc_internal_error ("in gfc_simplify_atan(): Bad type"); } @@ -1117,14 +1114,15 @@ gfc_simplify_atanh (gfc_expr *x) "to 1", &x->where); return &gfc_bad_expr; } - - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE); break; + case BT_COMPLEX: - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); break; + default: gfc_internal_error ("in gfc_simplify_atanh(): Bad type"); } @@ -1148,8 +1146,7 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) return &gfc_bad_expr; } - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE); return range_check (result, "ATAN2"); @@ -1157,14 +1154,14 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) gfc_expr * -gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED) +gfc_simplify_bessel_j0 (gfc_expr *x) { gfc_expr *result; if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE); return range_check (result, "BESSEL_J0"); @@ -1172,14 +1169,14 @@ gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED) gfc_expr * -gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED) +gfc_simplify_bessel_j1 (gfc_expr *x) { gfc_expr *result; if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE); return range_check (result, "BESSEL_J1"); @@ -1187,8 +1184,7 @@ gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED) gfc_expr * -gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED, - gfc_expr *x ATTRIBUTE_UNUSED) +gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x) { gfc_expr *result; long n; @@ -1197,22 +1193,207 @@ gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED, return NULL; n = mpz_get_si (order->value.integer); - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE); return range_check (result, "BESSEL_JN"); } +/* Simplify transformational form of JN and YN. */ + +static gfc_expr * +gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x, + bool jn) +{ + gfc_expr *result; + gfc_expr *e; + long n1, n2; + int i; + mpfr_t x2rev, last1, last2; + + if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT + || order2->expr_type != EXPR_CONSTANT) + return NULL; + + n1 = mpz_get_si (order1->value.integer); + n2 = mpz_get_si (order2->value.integer); + result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where); + result->rank = 1; + result->shape = gfc_get_shape (1); + mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0)); + + if (n2 < n1) + return result; + + /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and + YN(N, 0.0) = -Inf. */ + + if (mpfr_cmp_ui (x->value.real, 0.0) == 0) + { + if (!jn && gfc_option.flag_range_check) + { + gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + if (jn && n1 == 0) + { + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_set_ui (e->value.real, 1, GFC_RND_MODE); + gfc_constructor_append_expr (&result->value.constructor, e, + &x->where); + n1++; + } + + for (i = n1; i <= n2; i++) + { + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + if (jn) + mpfr_set_ui (e->value.real, 0, GFC_RND_MODE); + else + mpfr_set_inf (e->value.real, -1); + gfc_constructor_append_expr (&result->value.constructor, e, + &x->where); + } + + return result; + } + + /* Use the faster but more verbose recurrence algorithm. Bessel functions + are stable for downward recursion and Neumann functions are stable + for upward recursion. It is + x2rev = 2.0/x, + J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x), + Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x). + Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */ + + gfc_set_model_kind (x->ts.kind); + + /* Get first recursion anchor. */ + + mpfr_init (last1); + if (jn) + mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE); + else + mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE); + + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_set (e->value.real, last1, GFC_RND_MODE); + if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) + { + mpfr_clear (last1); + gfc_free_expr (e); + gfc_free_expr (result); + return &gfc_bad_expr; + } + gfc_constructor_append_expr (&result->value.constructor, e, &x->where); + + if (n1 == n2) + { + mpfr_clear (last1); + return result; + } + + /* Get second recursion anchor. */ + + mpfr_init (last2); + if (jn) + mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE); + else + mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE); + + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_set (e->value.real, last2, GFC_RND_MODE); + if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) + { + mpfr_clear (last1); + mpfr_clear (last2); + gfc_free_expr (e); + gfc_free_expr (result); + return &gfc_bad_expr; + } + if (jn) + gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2); + else + gfc_constructor_append_expr (&result->value.constructor, e, &x->where); + + if (n1 + 1 == n2) + { + mpfr_clear (last1); + mpfr_clear (last2); + return result; + } + + /* Start actual recursion. */ + + mpfr_init (x2rev); + mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE); + + for (i = 2; i <= n2-n1; i++) + { + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + /* Special case: For YN, if the previous N gave -INF, set + also N+1 to -INF. */ + if (!jn && !gfc_option.flag_range_check && mpfr_inf_p (last2)) + { + mpfr_set_inf (e->value.real, -1); + gfc_constructor_append_expr (&result->value.constructor, e, + &x->where); + continue; + } + + mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1), + GFC_RND_MODE); + mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE); + mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE); + + if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) + goto error; + + if (jn) + gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, + -i-1); + else + gfc_constructor_append_expr (&result->value.constructor, e, &x->where); + + mpfr_set (last1, last2, GFC_RND_MODE); + mpfr_set (last2, e->value.real, GFC_RND_MODE); + } + + mpfr_clear (last1); + mpfr_clear (last2); + mpfr_clear (x2rev); + return result; + +error: + mpfr_clear (last1); + mpfr_clear (last2); + mpfr_clear (x2rev); + gfc_free_expr (e); + gfc_free_expr (result); + return &gfc_bad_expr; +} + + +gfc_expr * +gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) +{ + return gfc_simplify_bessel_n2 (order1, order2, x, true); +} + + gfc_expr * -gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED) +gfc_simplify_bessel_y0 (gfc_expr *x) { gfc_expr *result; if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE); return range_check (result, "BESSEL_Y0"); @@ -1220,14 +1401,14 @@ gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED) gfc_expr * -gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED) +gfc_simplify_bessel_y1 (gfc_expr *x) { gfc_expr *result; if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE); return range_check (result, "BESSEL_Y1"); @@ -1235,8 +1416,7 @@ gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED) gfc_expr * -gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED, - gfc_expr *x ATTRIBUTE_UNUSED) +gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x) { gfc_expr *result; long n; @@ -1245,7 +1425,7 @@ gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED, return NULL; n = mpz_get_si (order->value.integer); - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE); return range_check (result, "BESSEL_YN"); @@ -1253,16 +1433,18 @@ gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED, gfc_expr * -gfc_simplify_bit_size (gfc_expr *e) +gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) { - gfc_expr *result; - int i; + return gfc_simplify_bessel_n2 (order1, order2, x, false); +} - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where); - mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size); - return result; +gfc_expr * +gfc_simplify_bit_size (gfc_expr *e) +{ + int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + return gfc_get_int_expr (e->ts.kind, &e->where, + gfc_integer_kinds[i].bit_size); } @@ -1275,9 +1457,78 @@ gfc_simplify_btest (gfc_expr *e, gfc_expr *bit) return NULL; if (gfc_extract_int (bit, &b) != NULL || b < 0) - return gfc_logical_expr (0, &e->where); + return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false); + + return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, + mpz_tstbit (e->value.integer, b)); +} + + +static int +compare_bitwise (gfc_expr *i, gfc_expr *j) +{ + mpz_t x, y; + int k, res; + + gcc_assert (i->ts.type == BT_INTEGER); + gcc_assert (j->ts.type == BT_INTEGER); + + mpz_init_set (x, i->value.integer); + k = gfc_validate_kind (i->ts.type, i->ts.kind, false); + convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); + + mpz_init_set (y, j->value.integer); + k = gfc_validate_kind (j->ts.type, j->ts.kind, false); + convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size); + + res = mpz_cmp (x, y); + mpz_clear (x); + mpz_clear (y); + return res; +} + + +gfc_expr * +gfc_simplify_bge (gfc_expr *i, gfc_expr *j) +{ + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, + compare_bitwise (i, j) >= 0); +} + + +gfc_expr * +gfc_simplify_bgt (gfc_expr *i, gfc_expr *j) +{ + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, + compare_bitwise (i, j) > 0); +} + - return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where); +gfc_expr * +gfc_simplify_ble (gfc_expr *i, gfc_expr *j) +{ + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, + compare_bitwise (i, j) <= 0); +} + + +gfc_expr * +gfc_simplify_blt (gfc_expr *i, gfc_expr *j) +{ + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, + compare_bitwise (i, j) < 0); } @@ -1294,11 +1545,10 @@ gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, kind, &e->where); - ceil = gfc_copy_expr (e); - mpfr_ceil (ceil->value.real, e->value.real); + + result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where); gfc_free_expr (ceil); @@ -1314,117 +1564,75 @@ gfc_simplify_char (gfc_expr *e, gfc_expr *k) } -/* Common subroutine for simplifying CMPLX and DCMPLX. */ +/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */ static gfc_expr * simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) { gfc_expr *result; - result = gfc_constant_result (BT_COMPLEX, kind, &x->where); + if (convert_boz (x, kind) == &gfc_bad_expr) + return &gfc_bad_expr; + + if (convert_boz (y, kind) == &gfc_bad_expr) + return &gfc_bad_expr; + + if (x->expr_type != EXPR_CONSTANT + || (y != NULL && y->expr_type != EXPR_CONSTANT)) + return NULL; + + result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where); switch (x->ts.type) { - case BT_INTEGER: - if (!x->is_boz) + case BT_INTEGER: mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE); - break; + break; - case BT_REAL: - mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE); - break; + case BT_REAL: + mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE); + break; - case BT_COMPLEX: - mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; + case BT_COMPLEX: + mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; - default: - gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)"); + default: + gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)"); } - if (y != NULL) - { - switch (y->ts.type) - { - case BT_INTEGER: - if (!y->is_boz) - mpfr_set_z (mpc_imagref (result->value.complex), - y->value.integer, GFC_RND_MODE); - break; - - case BT_REAL: - mpfr_set (mpc_imagref (result->value.complex), - y->value.real, GFC_RND_MODE); - break; - - default: - gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)"); - } - } + if (!y) + return range_check (result, name); - /* Handle BOZ. */ - if (x->is_boz) + switch (y->ts.type) { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.kind = result->ts.kind; - ts.type = BT_REAL; - if (!gfc_convert_boz (x, &ts)) - return &gfc_bad_expr; - mpfr_set (mpc_realref (result->value.complex), - x->value.real, GFC_RND_MODE); - } + case BT_INTEGER: + mpfr_set_z (mpc_imagref (result->value.complex), + y->value.integer, GFC_RND_MODE); + break; - if (y && y->is_boz) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.kind = result->ts.kind; - ts.type = BT_REAL; - if (!gfc_convert_boz (y, &ts)) - return &gfc_bad_expr; - mpfr_set (mpc_imagref (result->value.complex), - y->value.real, GFC_RND_MODE); + case BT_REAL: + mpfr_set (mpc_imagref (result->value.complex), + y->value.real, GFC_RND_MODE); + break; + + default: + gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)"); } return range_check (result, name); } -/* Function called when we won't simplify an expression like CMPLX (or - COMPLEX or DCMPLX) but still want to convert BOZ arguments. */ - -static gfc_expr * -only_convert_cmplx_boz (gfc_expr *x, gfc_expr *y, int kind) -{ - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.type = BT_REAL; - ts.kind = kind; - - if (x->is_boz && !gfc_convert_boz (x, &ts)) - return &gfc_bad_expr; - - if (y && y->is_boz && !gfc_convert_boz (y, &ts)) - return &gfc_bad_expr; - - return NULL; -} - - gfc_expr * gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k) { int kind; - kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind); + kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind); if (kind == -1) return &gfc_bad_expr; - if (x->expr_type != EXPR_CONSTANT - || (y != NULL && y->expr_type != EXPR_CONSTANT)) - return only_convert_cmplx_boz (x, y, kind); - return simplify_cmplx ("CMPLX", x, y, kind); } @@ -1434,24 +1642,16 @@ gfc_simplify_complex (gfc_expr *x, gfc_expr *y) { int kind; - if (x->ts.type == BT_INTEGER) - { - if (y->ts.type == BT_INTEGER) - kind = gfc_default_real_kind; - else - kind = y->ts.kind; - } + if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER) + kind = gfc_default_complex_kind; + else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER) + kind = x->ts.kind; + else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL) + kind = y->ts.kind; + else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL) + kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind; else - { - if (y->ts.type == BT_REAL) - kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind; - else - kind = x->ts.kind; - } - - if (x->expr_type != EXPR_CONSTANT - || (y != NULL && y->expr_type != EXPR_CONSTANT)) - return only_convert_cmplx_boz (x, y, kind); + gcc_unreachable (); return simplify_cmplx ("COMPLEX", x, y, kind); } @@ -1467,6 +1667,7 @@ gfc_simplify_conjg (gfc_expr *e) result = gfc_copy_expr (e); mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE); + return range_check (result, "CONJG"); } @@ -1479,23 +1680,24 @@ gfc_simplify_cos (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); switch (x->ts.type) { - case BT_REAL: - mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE); - break; - case BT_COMPLEX: - gfc_set_model_kind (x->ts.kind); - mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - default: - gfc_internal_error ("in gfc_simplify_cos(): Bad type"); + case BT_REAL: + mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + gfc_set_model_kind (x->ts.kind); + mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_cos(): Bad type"); } return range_check (result, "COS"); - } @@ -1507,14 +1709,21 @@ gfc_simplify_cosh (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - if (x->ts.type == BT_REAL) - mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE); - else if (x->ts.type == BT_COMPLEX) - mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - else - gcc_unreachable (); + switch (x->ts.type) + { + case BT_REAL: + mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gcc_unreachable (); + } return range_check (result, "COSH"); } @@ -1542,18 +1751,13 @@ gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) Whenever gfc_count is called, '1' is added to the result. */ return !dim || mask->rank == 1 ? simplify_transformation_to_scalar (result, mask, mask, gfc_count) : - simplify_transformation_to_array (result, mask, dim, mask, gfc_count); + simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL); } gfc_expr * gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) { - - if (x->expr_type != EXPR_CONSTANT - || (y != NULL && y->expr_type != EXPR_CONSTANT)) - return only_convert_cmplx_boz (x, y, gfc_default_double_kind); - return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind); } @@ -1566,38 +1770,12 @@ gfc_simplify_dble (gfc_expr *e) if (e->expr_type != EXPR_CONSTANT) return NULL; - switch (e->ts.type) - { - case BT_INTEGER: - if (!e->is_boz) - result = gfc_int2real (e, gfc_default_double_kind); - break; - - case BT_REAL: - result = gfc_real2real (e, gfc_default_double_kind); - break; - - case BT_COMPLEX: - result = gfc_complex2real (e, gfc_default_double_kind); - break; - - default: - gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where); - } + if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr) + return &gfc_bad_expr; - if (e->ts.type == BT_INTEGER && e->is_boz) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.type = BT_REAL; - ts.kind = gfc_default_double_kind; - result = gfc_copy_expr (e); - if (!gfc_convert_boz (result, &ts)) - { - gfc_free_expr (result); - return &gfc_bad_expr; - } - } + result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind); + if (result == &gfc_bad_expr) + return &gfc_bad_expr; return range_check (result, "DBLE"); } @@ -1609,22 +1787,23 @@ gfc_simplify_digits (gfc_expr *x) int i, digits; i = gfc_validate_kind (x->ts.type, x->ts.kind, false); + switch (x->ts.type) { - case BT_INTEGER: - digits = gfc_integer_kinds[i].digits; - break; + case BT_INTEGER: + digits = gfc_integer_kinds[i].digits; + break; - case BT_REAL: - case BT_COMPLEX: - digits = gfc_real_kinds[i].digits; - break; + case BT_REAL: + case BT_COMPLEX: + digits = gfc_real_kinds[i].digits; + break; - default: - gcc_unreachable (); + default: + gcc_unreachable (); } - return gfc_int_expr (digits); + return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits); } @@ -1638,29 +1817,29 @@ gfc_simplify_dim (gfc_expr *x, gfc_expr *y) return NULL; kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - result = gfc_constant_result (x->ts.type, kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, kind, &x->where); switch (x->ts.type) { - case BT_INTEGER: - if (mpz_cmp (x->value.integer, y->value.integer) > 0) - mpz_sub (result->value.integer, x->value.integer, y->value.integer); - else - mpz_set_ui (result->value.integer, 0); + case BT_INTEGER: + if (mpz_cmp (x->value.integer, y->value.integer) > 0) + mpz_sub (result->value.integer, x->value.integer, y->value.integer); + else + mpz_set_ui (result->value.integer, 0); - break; + break; - case BT_REAL: - if (mpfr_cmp (x->value.real, y->value.real) > 0) - mpfr_sub (result->value.real, x->value.real, y->value.real, - GFC_RND_MODE); - else - mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + case BT_REAL: + if (mpfr_cmp (x->value.real, y->value.real) > 0) + mpfr_sub (result->value.real, x->value.real, y->value.real, + GFC_RND_MODE); + else + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); - break; + break; - default: - gfc_internal_error ("gfc_simplify_dim(): Bad type"); + default: + gfc_internal_error ("gfc_simplify_dim(): Bad type"); } return range_check (result, "DIM"); @@ -1670,8 +1849,6 @@ gfc_simplify_dim (gfc_expr *x, gfc_expr *y) gfc_expr* gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) { - gfc_expr *result; - if (!is_constant_array_expr (vector_a) || !is_constant_array_expr (vector_b)) return NULL; @@ -1680,16 +1857,7 @@ gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) gcc_assert (vector_b->rank == 1); gcc_assert (gfc_compare_types (&vector_a->ts, &vector_b->ts)); - if (vector_a->value.constructor && vector_b->value.constructor) - return compute_dot_product (vector_a->value.constructor, 1, - vector_b->value.constructor, 1); - - /* Zero sized array ... */ - result = gfc_constant_result (vector_a->ts.type, - vector_a->ts.kind, - &vector_a->where); - init_result_expr (result, 0, NULL); - return result; + return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0); } @@ -1701,20 +1869,77 @@ gfc_simplify_dprod (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where); - a1 = gfc_real2real (x, gfc_default_double_kind); a2 = gfc_real2real (y, gfc_default_double_kind); + result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where); mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE); - gfc_free_expr (a1); gfc_free_expr (a2); + gfc_free_expr (a1); return range_check (result, "DPROD"); } +static gfc_expr * +simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg, + bool right) +{ + gfc_expr *result; + int i, k, size, shift; + + if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT + || shiftarg->expr_type != EXPR_CONSTANT) + return NULL; + + k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false); + size = gfc_integer_kinds[k].bit_size; + + if (gfc_extract_int (shiftarg, &shift) != NULL) + { + gfc_error ("Invalid SHIFT argument of DSHIFTL at %L", &shiftarg->where); + return &gfc_bad_expr; + } + + gcc_assert (shift >= 0 && shift <= size); + + /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */ + if (right) + shift = size - shift; + + result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where); + mpz_set_ui (result->value.integer, 0); + + for (i = 0; i < shift; i++) + if (mpz_tstbit (arg2->value.integer, size - shift + i)) + mpz_setbit (result->value.integer, i); + + for (i = 0; i < size - shift; i++) + if (mpz_tstbit (arg1->value.integer, i)) + mpz_setbit (result->value.integer, shift + i); + + /* Convert to a signed value. */ + convert_mpz_to_signed (result->value.integer, size); + + return result; +} + + +gfc_expr * +gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) +{ + return simplify_dshift (arg1, arg2, shiftarg, true); +} + + +gfc_expr * +gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) +{ + return simplify_dshift (arg1, arg2, shiftarg, false); +} + + gfc_expr * gfc_simplify_erf (gfc_expr *x) { @@ -1723,8 +1948,7 @@ gfc_simplify_erf (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE); return range_check (result, "ERF"); @@ -1739,8 +1963,7 @@ gfc_simplify_erfc (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE); return range_check (result, "ERFC"); @@ -1871,7 +2094,7 @@ gfc_simplify_erfc_scaled (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0) asympt_erfc_scaled (result->value.real, x->value.real); else @@ -1892,8 +2115,7 @@ gfc_simplify_epsilon (gfc_expr *e) i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); - + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE); return range_check (result, "EPSILON"); @@ -1908,21 +2130,21 @@ gfc_simplify_exp (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); switch (x->ts.type) { - case BT_REAL: - mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE); - break; + case BT_REAL: + mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE); + break; - case BT_COMPLEX: - gfc_set_model_kind (x->ts.kind); - mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; + case BT_COMPLEX: + gfc_set_model_kind (x->ts.kind); + mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; - default: - gfc_internal_error ("in gfc_simplify_exp(): Bad type"); + default: + gfc_internal_error ("in gfc_simplify_exp(): Bad type"); } return range_check (result, "EXP"); @@ -1938,8 +2160,8 @@ gfc_simplify_exponent (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &x->where); + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &x->where); gfc_set_model (x->value.real); @@ -1966,21 +2188,14 @@ gfc_simplify_float (gfc_expr *a) if (a->is_boz) { - gfc_typespec ts; - gfc_clear_ts (&ts); - - ts.type = BT_REAL; - ts.kind = gfc_default_real_kind; + if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr) + return &gfc_bad_expr; result = gfc_copy_expr (a); - if (!gfc_convert_boz (result, &ts)) - { - gfc_free_expr (result); - return &gfc_bad_expr; - } } else result = gfc_int2real (a, gfc_default_real_kind); + return range_check (result, "FLOAT"); } @@ -1999,12 +2214,12 @@ gfc_simplify_floor (gfc_expr *e, gfc_expr *k) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, kind, &e->where); - gfc_set_model_kind (kind); + mpfr_init (floor); mpfr_floor (floor, e->value.real); + result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); gfc_mpfr_to_mpz (result->value.integer, floor, &e->where); mpfr_clear (floor); @@ -2022,7 +2237,7 @@ gfc_simplify_fraction (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); if (mpfr_sgn (x->value.real) == 0) { @@ -2059,8 +2274,7 @@ gfc_simplify_gamma (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE); return range_check (result, "GAMMA"); @@ -2074,21 +2288,20 @@ gfc_simplify_huge (gfc_expr *e) int i; i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - - result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); switch (e->ts.type) { - case BT_INTEGER: - mpz_set (result->value.integer, gfc_integer_kinds[i].huge); - break; + case BT_INTEGER: + mpz_set (result->value.integer, gfc_integer_kinds[i].huge); + break; - case BT_REAL: - mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); - break; + case BT_REAL: + mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); + break; - default: - gcc_unreachable (); + default: + gcc_unreachable (); } return result; @@ -2103,7 +2316,7 @@ gfc_simplify_hypot (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE); return range_check (result, "HYPOT"); } @@ -2117,6 +2330,7 @@ gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind) { gfc_expr *result; gfc_char_t index; + int k; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -2133,15 +2347,54 @@ gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind) gfc_warning ("Argument of IACHAR function at %L outside of range 0..127", &e->where); - if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL) + k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind); + if (k == -1) return &gfc_bad_expr; - result->where = e->where; + result = gfc_get_int_expr (k, &e->where, index); return range_check (result, "IACHAR"); } +static gfc_expr * +do_bit_and (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_INTEGER + && result->expr_type == EXPR_CONSTANT); + + mpz_and (result->value.integer, result->value.integer, e->value.integer); + return result; +} + + +gfc_expr * +gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, -1, do_bit_and); +} + + +static gfc_expr * +do_bit_ior (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_INTEGER + && result->expr_type == EXPR_CONSTANT); + + mpz_ior (result->value.integer, result->value.integer, e->value.integer); + return result; +} + + +gfc_expr * +gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, 0, do_bit_ior); +} + + gfc_expr * gfc_simplify_iand (gfc_expr *x, gfc_expr *y) { @@ -2150,8 +2403,7 @@ gfc_simplify_iand (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where); - + result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); mpz_and (result->value.integer, x->value.integer, y->value.integer); return range_check (result, "IAND"); @@ -2232,7 +2484,7 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) return &gfc_bad_expr; } - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); convert_mpz_to_unsigned (result->value.integer, gfc_integer_kinds[k].bit_size); @@ -2306,6 +2558,7 @@ gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind) { gfc_expr *result; gfc_char_t index; + int k; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -2318,10 +2571,12 @@ gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind) index = e->value.character.string[0]; - if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL) + k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind); + if (k == -1) return &gfc_bad_expr; - result->where = e->where; + result = gfc_get_int_expr (k, &e->where, index); + return range_check (result, "ICHAR"); } @@ -2334,8 +2589,7 @@ gfc_simplify_ieor (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where); - + result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); mpz_xor (result->value.integer, x->value.integer, y->value.integer); return range_check (result, "IEOR"); @@ -2362,7 +2616,7 @@ gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind) if (k == -1) return &gfc_bad_expr; - result = gfc_constant_result (BT_INTEGER, k, &x->where); + result = gfc_get_constant_expr (BT_INTEGER, k, &x->where); len = x->value.character.length; lensub = y->value.character.length; @@ -2487,73 +2741,34 @@ done: } -gfc_expr * -gfc_simplify_int (gfc_expr *e, gfc_expr *k) +static gfc_expr * +simplify_intconv (gfc_expr *e, int kind, const char *name) { gfc_expr *result = NULL; - int kind; - - kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); - if (kind == -1) - return &gfc_bad_expr; if (e->expr_type != EXPR_CONSTANT) return NULL; - switch (e->ts.type) - { - case BT_INTEGER: - result = gfc_int2int (e, kind); - break; - - case BT_REAL: - result = gfc_real2int (e, kind); - break; - - case BT_COMPLEX: - result = gfc_complex2int (e, kind); - break; - - default: - gfc_error ("Argument of INT at %L is not a valid type", &e->where); - return &gfc_bad_expr; - } + result = gfc_convert_constant (e, BT_INTEGER, kind); + if (result == &gfc_bad_expr) + return &gfc_bad_expr; - return range_check (result, "INT"); + return range_check (result, name); } -static gfc_expr * -simplify_intconv (gfc_expr *e, int kind, const char *name) +gfc_expr * +gfc_simplify_int (gfc_expr *e, gfc_expr *k) { - gfc_expr *result = NULL; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - switch (e->ts.type) - { - case BT_INTEGER: - result = gfc_int2int (e, kind); - break; - - case BT_REAL: - result = gfc_real2int (e, kind); - break; - - case BT_COMPLEX: - result = gfc_complex2int (e, kind); - break; + int kind; - default: - gfc_error ("Argument of %s at %L is not a valid type", name, &e->where); - return &gfc_bad_expr; - } + kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; - return range_check (result, name); + return simplify_intconv (e, kind, "INT"); } - gfc_expr * gfc_simplify_int2 (gfc_expr *e) { @@ -2583,15 +2798,15 @@ gfc_simplify_ifix (gfc_expr *e) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &e->where); - rtrunc = gfc_copy_expr (e); - mpfr_trunc (rtrunc->value.real, e->value.real); + + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &e->where); gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); gfc_free_expr (rtrunc); + return range_check (result, "IFIX"); } @@ -2604,15 +2819,15 @@ gfc_simplify_idint (gfc_expr *e) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &e->where); - rtrunc = gfc_copy_expr (e); - mpfr_trunc (rtrunc->value.real, e->value.real); + + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &e->where); gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); gfc_free_expr (rtrunc); + return range_check (result, "IDINT"); } @@ -2625,111 +2840,137 @@ gfc_simplify_ior (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where); - + result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); mpz_ior (result->value.integer, x->value.integer, y->value.integer); + return range_check (result, "IOR"); } +static gfc_expr * +do_bit_xor (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_INTEGER + && result->expr_type == EXPR_CONSTANT); + + mpz_xor (result->value.integer, result->value.integer, e->value.integer); + return result; +} + + gfc_expr * -gfc_simplify_is_iostat_end (gfc_expr *x) +gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) { - gfc_expr *result; + return simplify_transformation (array, dim, mask, 0, do_bit_xor); +} + + +gfc_expr * +gfc_simplify_is_iostat_end (gfc_expr *x) +{ if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &x->where); - result->value.logical = (mpz_cmp_si (x->value.integer, LIBERROR_END) == 0); - - return result; + return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, + mpz_cmp_si (x->value.integer, + LIBERROR_END) == 0); } gfc_expr * gfc_simplify_is_iostat_eor (gfc_expr *x) { - gfc_expr *result; - if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &x->where); - result->value.logical = (mpz_cmp_si (x->value.integer, LIBERROR_EOR) == 0); - - return result; + return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, + mpz_cmp_si (x->value.integer, + LIBERROR_EOR) == 0); } gfc_expr * gfc_simplify_isnan (gfc_expr *x) { - gfc_expr *result; - if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind, - &x->where); - result->value.logical = mpfr_nan_p (x->value.real); - - return result; + return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, + mpfr_nan_p (x->value.real)); } -gfc_expr * -gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) +/* Performs a shift on its first argument. Depending on the last + argument, the shift can be arithmetic, i.e. with filling from the + left like in the SHIFTA intrinsic. */ +static gfc_expr * +simplify_shift (gfc_expr *e, gfc_expr *s, const char *name, + bool arithmetic, int direction) { gfc_expr *result; - int shift, ashift, isize, k, *bits, i; + int ashift, *bits, i, k, bitsize, shift; if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) return NULL; - if (gfc_extract_int (s, &shift) != NULL) { - gfc_error ("Invalid second argument of ISHFT at %L", &s->where); + gfc_error ("Invalid second argument of %s at %L", name, &s->where); return &gfc_bad_expr; } k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false); + bitsize = gfc_integer_kinds[k].bit_size; - isize = gfc_integer_kinds[k].bit_size; + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); - if (shift >= 0) - ashift = shift; - else - ashift = -shift; + if (shift == 0) + { + mpz_set (result->value.integer, e->value.integer); + return result; + } - if (ashift > isize) + if (direction > 0 && shift < 0) { - gfc_error ("Magnitude of second argument of ISHFT exceeds bit size " - "at %L", &s->where); + /* Left shift, as in SHIFTL. */ + gfc_error ("Second argument of %s is negative at %L", name, &e->where); return &gfc_bad_expr; } + else if (direction < 0) + { + /* Right shift, as in SHIFTR or SHIFTA. */ + if (shift < 0) + { + gfc_error ("Second argument of %s is negative at %L", + name, &e->where); + return &gfc_bad_expr; + } + + shift = -shift; + } - result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); + ashift = (shift >= 0 ? shift : -shift); - if (shift == 0) + if (ashift > bitsize) { - mpz_set (result->value.integer, e->value.integer); - return range_check (result, "ISHFT"); + gfc_error ("Magnitude of second argument of %s exceeds bit size " + "at %L", name, &e->where); + return &gfc_bad_expr; } - - bits = XCNEWVEC (int, isize); - for (i = 0; i < isize; i++) + bits = XCNEWVEC (int, bitsize); + + for (i = 0; i < bitsize; i++) bits[i] = mpz_tstbit (e->value.integer, i); if (shift > 0) { + /* Left shift. */ for (i = 0; i < shift; i++) mpz_clrbit (result->value.integer, i); - for (i = 0; i < isize - shift; i++) + for (i = 0; i < bitsize - shift; i++) { if (bits[i] == 0) mpz_clrbit (result->value.integer, i + shift); @@ -2739,10 +2980,15 @@ gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) } else { - for (i = isize - 1; i >= isize - ashift; i--) - mpz_clrbit (result->value.integer, i); + /* Right shift. */ + if (arithmetic && bits[bitsize - 1]) + for (i = bitsize - 1; i >= bitsize - ashift; i--) + mpz_setbit (result->value.integer, i); + else + for (i = bitsize - 1; i >= bitsize - ashift; i--) + mpz_clrbit (result->value.integer, i); - for (i = isize - 1; i >= ashift; i--) + for (i = bitsize - 1; i >= ashift; i--) { if (bits[i] == 0) mpz_clrbit (result->value.integer, i - ashift); @@ -2751,14 +2997,56 @@ gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) } } - convert_mpz_to_signed (result->value.integer, isize); - + convert_mpz_to_signed (result->value.integer, bitsize); gfc_free (bits); + return result; } gfc_expr * +gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "ISHFT", false, 0); +} + + +gfc_expr * +gfc_simplify_lshift (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "LSHIFT", false, 1); +} + + +gfc_expr * +gfc_simplify_rshift (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "RSHIFT", true, -1); +} + + +gfc_expr * +gfc_simplify_shifta (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "SHIFTA", true, -1); +} + + +gfc_expr * +gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "SHIFTL", false, 1); +} + + +gfc_expr * +gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "SHIFTR", false, -1); +} + + +gfc_expr * gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) { gfc_expr *result; @@ -2814,7 +3102,7 @@ gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) return &gfc_bad_expr; } - result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); mpz_set (result->value.integer, e->value.integer); @@ -2877,49 +3165,72 @@ gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) gfc_expr * gfc_simplify_kind (gfc_expr *e) { - - if (e->ts.type == BT_DERIVED) - { - gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where); - return &gfc_bad_expr; - } - - return gfc_int_expr (e->ts.kind); + return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind); } static gfc_expr * simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, - gfc_array_spec *as, gfc_ref *ref) + gfc_array_spec *as, gfc_ref *ref, bool coarray) { gfc_expr *l, *u, *result; int k; - /* The last dimension of an assumed-size array is special. */ - if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) - { - if (as->lower[d-1]->expr_type == EXPR_CONSTANT) - return gfc_copy_expr (as->lower[d-1]); - else - return NULL; - } - k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", gfc_default_integer_kind); if (k == -1) return &gfc_bad_expr; - result = gfc_constant_result (BT_INTEGER, k, &array->where); + result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); + /* For non-variables, LBOUND(expr, DIM=n) = 1 and + UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */ + if (!coarray && array->expr_type != EXPR_VARIABLE) + { + if (upper) + { + gfc_expr* dim = result; + mpz_set_si (dim->value.integer, d); + + result = gfc_simplify_size (array, dim, kind); + gfc_free_expr (dim); + if (!result) + goto returnNull; + } + else + mpz_set_si (result->value.integer, 1); + + goto done; + } + + /* Otherwise, we have a variable expression. */ + gcc_assert (array->expr_type == EXPR_VARIABLE); + gcc_assert (as); + + /* The last dimension of an assumed-size array is special. */ + if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) + || (coarray && d == as->rank + as->corank)) + { + if (as->lower[d-1]->expr_type == EXPR_CONSTANT) + { + gfc_free_expr (result); + return gfc_copy_expr (as->lower[d-1]); + } + + goto returnNull; + } + + result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); /* Then, we need to know the extent of the given dimension. */ - if (ref->u.ar.type == AR_FULL) + if (coarray || ref->u.ar.type == AR_FULL) { l = as->lower[d-1]; u = as->upper[d-1]; - if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT) - return NULL; + if (l->expr_type != EXPR_CONSTANT || u == NULL + || u->expr_type != EXPR_CONSTANT) + goto returnNull; if (mpz_cmp (l->value.integer, u->value.integer) > 0) { @@ -2942,15 +3253,20 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, { if (upper) { - if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer) + if (gfc_ref_dimen_size (&ref->u.ar, d-1, &result->value.integer, NULL) != SUCCESS) - return NULL; + goto returnNull; } else mpz_set_si (result->value.integer, (long int) 1); } +done: return range_check (result, upper ? "UBOUND" : "LBOUND"); + +returnNull: + gfc_free_expr (result); + return NULL; } @@ -2962,7 +3278,11 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) int d; if (array->expr_type != EXPR_VARIABLE) - return NULL; + { + as = NULL; + ref = NULL; + goto done; + } /* Follow any component references. */ as = array->symtree->n.sym->as; @@ -2981,7 +3301,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) /* We're done because 'as' has already been set in the previous iteration. */ if (!ref->next) - goto done; + goto done; /* Fall through. */ @@ -3008,7 +3328,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) done: - if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE) + if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)) return NULL; if (dim == NULL) @@ -3016,11 +3336,10 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) /* Multi-dimensional bounds. */ gfc_expr *bounds[GFC_MAX_DIMENSIONS]; gfc_expr *e; - gfc_constructor *head, *tail; int k; /* UBOUND(ARRAY) is not valid for an assumed-size array. */ - if (upper && as->type == AS_ASSUMED_SIZE) + if (upper && as && as->type == AS_ASSUMED_SIZE) { /* An error message will be emitted in check_assumed_size_reference (resolve.c). */ @@ -3030,7 +3349,8 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) /* Simplify the bounds for each dimension. */ for (d = 0; d < array->rank; d++) { - bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref); + bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref, + false); if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) { int j; @@ -3042,18 +3362,12 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) } /* Allocate the result expression. */ - e = gfc_get_expr (); - e->where = array->where; - e->expr_type = EXPR_ARRAY; - e->ts.type = BT_INTEGER; k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", - gfc_default_integer_kind); + gfc_default_integer_kind); if (k == -1) - { - gfc_free_expr (e); - return &gfc_bad_expr; - } - e->ts.kind = k; + return &gfc_bad_expr; + + e = gfc_get_array_expr (BT_INTEGER, k, &array->where); /* The result is a rank 1 array; its size is the rank of the first argument to {L,U}BOUND. */ @@ -3062,23 +3376,142 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) mpz_init_set_ui (e->shape[0], array->rank); /* Create the constructor for this array. */ - head = tail = NULL; for (d = 0; d < array->rank; d++) + gfc_constructor_append_expr (&e->value.constructor, + bounds[d], &e->where); + + return e; + } + else + { + /* A DIM argument is specified. */ + if (dim->expr_type != EXPR_CONSTANT) + return NULL; + + d = mpz_get_si (dim->value.integer); + + if (d < 1 || d > array->rank + || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper)) { - /* Get a new constructor element. */ - if (head == NULL) - head = tail = gfc_get_constructor (); - else + gfc_error ("DIM argument at %L is out of bounds", &dim->where); + return &gfc_bad_expr; + } + + return simplify_bound_dim (array, kind, d, upper, as, ref, false); + } +} + + +static gfc_expr * +simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) +{ + gfc_ref *ref; + gfc_array_spec *as; + int d; + + if (array->expr_type != EXPR_VARIABLE) + return NULL; + + /* Follow any component references. */ + as = array->symtree->n.sym->as; + for (ref = array->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + switch (ref->u.ar.type) + { + case AR_ELEMENT: + if (ref->next == NULL) + { + gcc_assert (ref->u.ar.as->corank > 0 + && ref->u.ar.as->rank == 0); + as = ref->u.ar.as; + goto done; + } + as = NULL; + continue; + + case AR_FULL: + /* We're done because 'as' has already been set in the + previous iteration. */ + if (!ref->next) + goto done; + + /* Fall through. */ + + case AR_UNKNOWN: + return NULL; + + case AR_SECTION: + as = ref->u.ar.as; + goto done; + } + + gcc_unreachable (); + + case REF_COMPONENT: + as = ref->u.c.component->as; + continue; + + case REF_SUBSTRING: + continue; + } + } + + gcc_unreachable (); + + done: + + if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE) + return NULL; + + if (dim == NULL) + { + /* Multi-dimensional cobounds. */ + gfc_expr *bounds[GFC_MAX_DIMENSIONS]; + gfc_expr *e; + int k; + + /* Simplify the cobounds for each dimension. */ + for (d = 0; d < as->corank; d++) + { + bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank, + upper, as, ref, true); + if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) { - tail->next = gfc_get_constructor (); - tail = tail->next; + int j; + + for (j = 0; j < d; j++) + gfc_free_expr (bounds[j]); + return bounds[d]; } + } - tail->where = e->where; - tail->expr = bounds[d]; + /* Allocate the result expression. */ + e = gfc_get_expr (); + e->where = array->where; + e->expr_type = EXPR_ARRAY; + e->ts.type = BT_INTEGER; + k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND", + gfc_default_integer_kind); + if (k == -1) + { + gfc_free_expr (e); + return &gfc_bad_expr; } - e->value.constructor = head; + e->ts.kind = k; + + /* The result is a rank 1 array; its size is the rank of the first + argument to {L,U}COBOUND. */ + e->rank = 1; + e->shape = gfc_get_shape (1); + mpz_init_set_ui (e->shape[0], as->corank); + /* Create the constructor for this array. */ + for (d = 0; d < as->corank; d++) + gfc_constructor_append_expr (&e->value.constructor, + bounds[d], &e->where); return e; } else @@ -3089,14 +3522,13 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) d = mpz_get_si (dim->value.integer); - if (d < 1 || d > as->rank - || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper)) + if (d < 1 || d > as->corank) { gfc_error ("DIM argument at %L is out of bounds", &dim->where); return &gfc_bad_expr; } - return simplify_bound_dim (array, kind, d, upper, as, ref); + return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true); } } @@ -3109,9 +3541,23 @@ gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) gfc_expr * +gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + gfc_expr *e; + /* return simplify_cobound (array, dim, kind, 0);*/ + + e = simplify_cobound (array, dim, kind, 0); + if (e != NULL) + return e; + + gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant " + "cobounds at %L", &array->where); + return &gfc_bad_expr; +} + +gfc_expr * gfc_simplify_leadz (gfc_expr *e) { - gfc_expr *result; unsigned long lz, bs; int i; @@ -3127,11 +3573,7 @@ gfc_simplify_leadz (gfc_expr *e) else lz = bs - mpz_sizeinbase (e->value.integer, 2); - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &e->where); - mpz_set_ui (result->value.integer, lz); - - return result; + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz); } @@ -3146,33 +3588,20 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind) if (e->expr_type == EXPR_CONSTANT) { - result = gfc_constant_result (BT_INTEGER, k, &e->where); + result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); mpz_set_si (result->value.integer, e->value.character.length); - if (gfc_range_check (result) == ARITH_OK) - return result; - else - { - gfc_free_expr (result); - return NULL; - } + return range_check (result, "LEN"); } - - if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL - && e->ts.u.cl->length->expr_type == EXPR_CONSTANT - && e->ts.u.cl->length->ts.type == BT_INTEGER) + else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL + && e->ts.u.cl->length->expr_type == EXPR_CONSTANT + && e->ts.u.cl->length->ts.type == BT_INTEGER) { - result = gfc_constant_result (BT_INTEGER, k, &e->where); + result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); mpz_set (result->value.integer, e->ts.u.cl->length->value.integer); - if (gfc_range_check (result) == ARITH_OK) - return result; - else - { - gfc_free_expr (result); - return NULL; - } + return range_check (result, "LEN"); } - - return NULL; + else + return NULL; } @@ -3180,7 +3609,7 @@ gfc_expr * gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind) { gfc_expr *result; - int count, len, lentrim, i; + int count, len, i; int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind); if (k == -1) @@ -3189,23 +3618,19 @@ gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, k, &e->where); len = e->value.character.length; - for (count = 0, i = 1; i <= len; i++) if (e->value.character.string[len - i] == ' ') count++; else break; - lentrim = len - count; - - mpz_set_si (result->value.integer, lentrim); + result = gfc_get_int_expr (k, &e->where, len - count); return range_check (result, "LEN_TRIM"); } gfc_expr * -gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED) +gfc_simplify_lgamma (gfc_expr *x) { gfc_expr *result; int sg; @@ -3213,8 +3638,7 @@ gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE); return range_check (result, "LGAMMA"); @@ -3227,7 +3651,8 @@ gfc_simplify_lge (gfc_expr *a, gfc_expr *b) if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) return NULL; - return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where); + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_string (a, b) >= 0); } @@ -3237,8 +3662,8 @@ gfc_simplify_lgt (gfc_expr *a, gfc_expr *b) if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) return NULL; - return gfc_logical_expr (gfc_compare_string (a, b) > 0, - &a->where); + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_string (a, b) > 0); } @@ -3248,7 +3673,8 @@ gfc_simplify_lle (gfc_expr *a, gfc_expr *b) if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) return NULL; - return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where); + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_string (a, b) <= 0); } @@ -3258,7 +3684,8 @@ gfc_simplify_llt (gfc_expr *a, gfc_expr *b) if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) return NULL; - return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where); + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_string (a, b) < 0); } @@ -3270,8 +3697,7 @@ gfc_simplify_log (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); switch (x->ts.type) { @@ -3324,8 +3750,7 @@ gfc_simplify_log10 (gfc_expr *x) return &gfc_bad_expr; } - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); - + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE); return range_check (result, "LOG10"); @@ -3335,7 +3760,6 @@ gfc_simplify_log10 (gfc_expr *x) gfc_expr * gfc_simplify_logical (gfc_expr *e, gfc_expr *k) { - gfc_expr *result; int kind; kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind); @@ -3345,11 +3769,7 @@ gfc_simplify_logical (gfc_expr *e, gfc_expr *k) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_LOGICAL, kind, &e->where); - - result->value.logical = e->value.logical; - - return result; + return gfc_get_logical_expr (kind, &e->where, e->value.logical); } @@ -3357,17 +3777,17 @@ gfc_expr* gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) { gfc_expr *result; - gfc_constructor *ma_ctor, *mb_ctor; - int row, result_rows, col, result_columns, stride_a, stride_b; + int row, result_rows, col, result_columns; + int stride_a, offset_a, stride_b, offset_b; if (!is_constant_array_expr (matrix_a) || !is_constant_array_expr (matrix_b)) return NULL; gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts)); - result = gfc_start_constructor (matrix_a->ts.type, - matrix_a->ts.kind, - &matrix_a->where); + result = gfc_get_array_expr (matrix_a->ts.type, + matrix_a->ts.kind, + &matrix_a->where); if (matrix_a->rank == 1 && matrix_b->rank == 2) { @@ -3406,25 +3826,22 @@ gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) else gcc_unreachable(); - ma_ctor = matrix_a->value.constructor; - mb_ctor = matrix_b->value.constructor; - + offset_a = offset_b = 0; for (col = 0; col < result_columns; ++col) { - ma_ctor = matrix_a->value.constructor; + offset_a = 0; for (row = 0; row < result_rows; ++row) { - gfc_expr *e; - e = compute_dot_product (ma_ctor, stride_a, - mb_ctor, 1); - - gfc_append_constructor (result, e); + gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a, + matrix_b, 1, offset_b); + gfc_constructor_append_expr (&result->value.constructor, + e, NULL); - ADVANCE (ma_ctor, 1); - } + offset_a += 1; + } - ADVANCE (mb_ctor, stride_b); + offset_b += stride_b; } return result; @@ -3432,6 +3849,73 @@ gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) gfc_expr * +gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg) +{ + gfc_expr *result; + int kind, arg, k; + const char *s; + + if (i->expr_type != EXPR_CONSTANT) + return NULL; + + kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; + k = gfc_validate_kind (BT_INTEGER, kind, false); + + s = gfc_extract_int (i, &arg); + gcc_assert (!s); + + result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); + + /* MASKR(n) = 2^n - 1 */ + mpz_set_ui (result->value.integer, 1); + mpz_mul_2exp (result->value.integer, result->value.integer, arg); + mpz_sub_ui (result->value.integer, result->value.integer, 1); + + convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); + + return result; +} + + +gfc_expr * +gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg) +{ + gfc_expr *result; + int kind, arg, k; + const char *s; + mpz_t z; + + if (i->expr_type != EXPR_CONSTANT) + return NULL; + + kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; + k = gfc_validate_kind (BT_INTEGER, kind, false); + + s = gfc_extract_int (i, &arg); + gcc_assert (!s); + + result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); + + /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */ + mpz_init_set_ui (z, 1); + mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size); + mpz_set_ui (result->value.integer, 1); + mpz_mul_2exp (result->value.integer, result->value.integer, + gfc_integer_kinds[k].bit_size - arg); + mpz_sub (result->value.integer, z, result->value.integer); + mpz_clear (z); + + convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); + + return result; +} + + +gfc_expr * gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) { if (tsource->expr_type != EXPR_CONSTANT @@ -3443,7 +3927,38 @@ gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) } -/* Selects bewteen current value and extremum for simplify_min_max +gfc_expr * +gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr) +{ + mpz_t arg1, arg2, mask; + gfc_expr *result; + + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT + || mask_expr->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where); + + /* Convert all argument to unsigned. */ + mpz_init_set (arg1, i->value.integer); + mpz_init_set (arg2, j->value.integer); + mpz_init_set (mask, mask_expr->value.integer); + + /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */ + mpz_and (arg1, arg1, mask); + mpz_com (mask, mask); + mpz_and (arg2, arg2, mask); + mpz_ior (result->value.integer, arg1, arg2); + + mpz_clear (arg1); + mpz_clear (arg2); + mpz_clear (mask); + + return result; +} + + +/* Selects between current value and extremum for simplify_min_max and simplify_minval_maxval. */ static void min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign) @@ -3584,26 +4099,25 @@ gfc_simplify_max (gfc_expr *e) static gfc_expr * simplify_minval_maxval (gfc_expr *expr, int sign) { - gfc_constructor *ctr, *extremum; + gfc_constructor *c, *extremum; gfc_intrinsic_sym * specific; extremum = NULL; specific = expr->value.function.isym; - ctr = expr->value.constructor; - - for (; ctr; ctr = ctr->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) { - if (ctr->expr->expr_type != EXPR_CONSTANT) + if (c->expr->expr_type != EXPR_CONSTANT) return NULL; if (extremum == NULL) { - extremum = ctr; + extremum = c; continue; } - min_max_choose (ctr->expr, extremum->expr, sign); + min_max_choose (c->expr, extremum->expr, sign); } if (extremum == NULL) @@ -3627,7 +4141,7 @@ gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) { if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask) return NULL; - + return simplify_minval_maxval (array, -1); } @@ -3637,6 +4151,7 @@ gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) { if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask) return NULL; + return simplify_minval_maxval (array, 1); } @@ -3644,30 +4159,18 @@ gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) gfc_expr * gfc_simplify_maxexponent (gfc_expr *x) { - gfc_expr *result; - int i; - - i = gfc_validate_kind (BT_REAL, x->ts.kind, false); - - result = gfc_int_expr (gfc_real_kinds[i].max_exponent); - result->where = x->where; - - return result; + int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); + return gfc_get_int_expr (gfc_default_integer_kind, &x->where, + gfc_real_kinds[i].max_exponent); } gfc_expr * gfc_simplify_minexponent (gfc_expr *x) { - gfc_expr *result; - int i; - - i = gfc_validate_kind (BT_REAL, x->ts.kind, false); - - result = gfc_int_expr (gfc_real_kinds[i].min_exponent); - result->where = x->where; - - return result; + int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); + return gfc_get_int_expr (gfc_default_integer_kind, &x->where, + gfc_real_kinds[i].min_exponent); } @@ -3682,41 +4185,41 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p) return NULL; kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; - result = gfc_constant_result (a->ts.type, kind, &a->where); + result = gfc_get_constant_expr (a->ts.type, kind, &a->where); switch (a->ts.type) { - case BT_INTEGER: - if (mpz_cmp_ui (p->value.integer, 0) == 0) - { - /* Result is processor-dependent. */ - gfc_error ("Second argument MOD at %L is zero", &a->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } - mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); - break; + case BT_INTEGER: + if (mpz_cmp_ui (p->value.integer, 0) == 0) + { + /* Result is processor-dependent. */ + gfc_error ("Second argument MOD at %L is zero", &a->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); + break; - case BT_REAL: - if (mpfr_cmp_ui (p->value.real, 0) == 0) - { - /* Result is processor-dependent. */ - gfc_error ("Second argument of MOD at %L is zero", &p->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } + case BT_REAL: + if (mpfr_cmp_ui (p->value.real, 0) == 0) + { + /* Result is processor-dependent. */ + gfc_error ("Second argument of MOD at %L is zero", &p->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } - gfc_set_model_kind (kind); - mpfr_init (tmp); - mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE); - mpfr_trunc (tmp, tmp); - mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE); - mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE); - mpfr_clear (tmp); - break; + gfc_set_model_kind (kind); + mpfr_init (tmp); + mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE); + mpfr_trunc (tmp, tmp); + mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE); + mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE); + mpfr_clear (tmp); + break; - default: - gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); + default: + gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); } return range_check (result, "MOD"); @@ -3734,43 +4237,43 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) return NULL; kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; - result = gfc_constant_result (a->ts.type, kind, &a->where); + result = gfc_get_constant_expr (a->ts.type, kind, &a->where); switch (a->ts.type) { - case BT_INTEGER: - if (mpz_cmp_ui (p->value.integer, 0) == 0) - { - /* Result is processor-dependent. This processor just opts - to not handle it at all. */ - gfc_error ("Second argument of MODULO at %L is zero", &a->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } - mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); + case BT_INTEGER: + if (mpz_cmp_ui (p->value.integer, 0) == 0) + { + /* Result is processor-dependent. This processor just opts + to not handle it at all. */ + gfc_error ("Second argument of MODULO at %L is zero", &a->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); - break; + break; - case BT_REAL: - if (mpfr_cmp_ui (p->value.real, 0) == 0) - { - /* Result is processor-dependent. */ - gfc_error ("Second argument of MODULO at %L is zero", &p->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } + case BT_REAL: + if (mpfr_cmp_ui (p->value.real, 0) == 0) + { + /* Result is processor-dependent. */ + gfc_error ("Second argument of MODULO at %L is zero", &p->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } - gfc_set_model_kind (kind); - mpfr_init (tmp); - mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE); - mpfr_floor (tmp, tmp); - mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE); - mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE); - mpfr_clear (tmp); - break; + gfc_set_model_kind (kind); + mpfr_init (tmp); + mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE); + mpfr_floor (tmp, tmp); + mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE); + mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE); + mpfr_clear (tmp); + break; - default: - gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); + default: + gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); } return range_check (result, "MODULO"); @@ -3859,12 +4362,10 @@ simplify_nint (const char *name, gfc_expr *e, gfc_expr *k) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_INTEGER, kind, &e->where); - itrunc = gfc_copy_expr (e); - mpfr_round (itrunc->value.real, e->value.real); + result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where); gfc_free_expr (itrunc); @@ -3878,11 +4379,9 @@ gfc_simplify_new_line (gfc_expr *e) { gfc_expr *result; - result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); - result->value.character.string = gfc_get_wide_string (2); - result->value.character.length = 1; + result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1); result->value.character.string[0] = '\n'; - result->value.character.string[1] = '\0'; /* For debugger */ + return result; } @@ -3901,6 +4400,65 @@ gfc_simplify_idnint (gfc_expr *e) } +static gfc_expr * +add_squared (gfc_expr *result, gfc_expr *e) +{ + mpfr_t tmp; + + gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_REAL + && result->expr_type == EXPR_CONSTANT); + + gfc_set_model_kind (result->ts.kind); + mpfr_init (tmp); + mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE); + mpfr_add (result->value.real, result->value.real, tmp, + GFC_RND_MODE); + mpfr_clear (tmp); + + return result; +} + + +static gfc_expr * +do_sqrt (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_REAL + && result->expr_type == EXPR_CONSTANT); + + mpfr_set (result->value.real, e->value.real, GFC_RND_MODE); + mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); + return result; +} + + +gfc_expr * +gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim) +{ + gfc_expr *result; + + if (!is_constant_array_expr (e) + || (dim != NULL && !gfc_is_constant_expr (dim))) + return NULL; + + result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where); + init_result_expr (result, 0, NULL); + + if (!dim || e->rank == 1) + { + result = simplify_transformation_to_scalar (result, e, NULL, + add_squared); + mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); + } + else + result = simplify_transformation_to_array (result, e, dim, NULL, + add_squared, &do_sqrt); + + return result; +} + + gfc_expr * gfc_simplify_not (gfc_expr *e) { @@ -3909,8 +4467,7 @@ gfc_simplify_not (gfc_expr *e) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); - + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); mpz_com (result->value.integer, e->value.integer); return range_check (result, "NOT"); @@ -3922,14 +4479,13 @@ gfc_simplify_null (gfc_expr *mold) { gfc_expr *result; - if (mold == NULL) + if (mold) { - result = gfc_get_expr (); - result->ts.type = BT_UNKNOWN; + result = gfc_copy_expr (mold); + result->expr_type = EXPR_NULL; } else - result = gfc_copy_expr (mold); - result->expr_type = EXPR_NULL; + result = gfc_get_null_expr (NULL); return result; } @@ -3939,8 +4495,16 @@ gfc_expr * gfc_simplify_num_images (void) { gfc_expr *result; + + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return &gfc_bad_expr; + } + /* FIXME: gfc_current_locus is wrong. */ - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &gfc_current_locus); mpz_set_si (result->value.integer, 1); return result; } @@ -3956,17 +4520,19 @@ gfc_simplify_or (gfc_expr *x, gfc_expr *y) return NULL; kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - if (x->ts.type == BT_INTEGER) - { - result = gfc_constant_result (BT_INTEGER, kind, &x->where); - mpz_ior (result->value.integer, x->value.integer, y->value.integer); - return range_check (result, "OR"); - } - else /* BT_LOGICAL */ + + switch (x->ts.type) { - result = gfc_constant_result (BT_LOGICAL, kind, &x->where); - result->value.logical = x->value.logical || y->value.logical; - return result; + case BT_INTEGER: + result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); + mpz_ior (result->value.integer, x->value.integer, y->value.integer); + return range_check (result, "OR"); + + case BT_LOGICAL: + return gfc_get_logical_expr (kind, &x->where, + x->value.logical || y->value.logical); + default: + gcc_unreachable(); } } @@ -3983,12 +4549,12 @@ gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) && !is_constant_array_expr(mask))) return NULL; - result = gfc_start_constructor (array->ts.type, - array->ts.kind, - &array->where); + result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); - array_ctor = array->value.constructor; - vector_ctor = vector ? vector->value.constructor : NULL; + array_ctor = gfc_constructor_first (array->value.constructor); + vector_ctor = vector + ? gfc_constructor_first (vector->value.constructor) + : NULL; if (mask->expr_type == EXPR_CONSTANT && mask->value.logical) @@ -3996,38 +4562,41 @@ gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) /* Copy all elements of ARRAY to RESULT. */ while (array_ctor) { - gfc_append_constructor (result, - gfc_copy_expr (array_ctor->expr)); + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (array_ctor->expr), + NULL); - ADVANCE (array_ctor, 1); - ADVANCE (vector_ctor, 1); + array_ctor = gfc_constructor_next (array_ctor); + vector_ctor = gfc_constructor_next (vector_ctor); } } else if (mask->expr_type == EXPR_ARRAY) { /* Copy only those elements of ARRAY to RESULT whose MASK equals .TRUE.. */ - mask_ctor = mask->value.constructor; + mask_ctor = gfc_constructor_first (mask->value.constructor); while (mask_ctor) { if (mask_ctor->expr->value.logical) { - gfc_append_constructor (result, - gfc_copy_expr (array_ctor->expr)); - ADVANCE (vector_ctor, 1); + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (array_ctor->expr), + NULL); + vector_ctor = gfc_constructor_next (vector_ctor); } - ADVANCE (array_ctor, 1); - ADVANCE (mask_ctor, 1); + array_ctor = gfc_constructor_next (array_ctor); + mask_ctor = gfc_constructor_next (mask_ctor); } } /* Append any left-over elements from VECTOR to RESULT. */ while (vector_ctor) { - gfc_append_constructor (result, - gfc_copy_expr (vector_ctor->expr)); - ADVANCE (vector_ctor, 1); + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (vector_ctor->expr), + NULL); + vector_ctor = gfc_constructor_next (vector_ctor); } result->shape = gfc_get_shape (1); @@ -4040,101 +4609,129 @@ gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) } -gfc_expr * -gfc_simplify_precision (gfc_expr *e) +static gfc_expr * +do_xor (gfc_expr *result, gfc_expr *e) { - gfc_expr *result; - int i; + gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_LOGICAL + && result->expr_type == EXPR_CONSTANT); - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + result->value.logical = result->value.logical != e->value.logical; + return result; +} - result = gfc_int_expr (gfc_real_kinds[i].precision); - result->where = e->where; - return result; + +gfc_expr * +gfc_simplify_parity (gfc_expr *e, gfc_expr *dim) +{ + return simplify_transformation (e, dim, NULL, 0, do_xor); } gfc_expr * -gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +gfc_simplify_popcnt (gfc_expr *e) { - gfc_expr *result; + int res, k; + mpz_t x; - if (!is_constant_array_expr (array) - || !gfc_is_constant_expr (dim)) + if (e->expr_type != EXPR_CONSTANT) return NULL; - if (mask - && !is_constant_array_expr (mask) - && mask->expr_type != EXPR_CONSTANT) + k = gfc_validate_kind (e->ts.type, e->ts.kind, false); + + /* Convert argument to unsigned, then count the '1' bits. */ + mpz_init_set (x, e->value.integer); + convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); + res = mpz_popcount (x); + mpz_clear (x); + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res); +} + + +gfc_expr * +gfc_simplify_poppar (gfc_expr *e) +{ + gfc_expr *popcnt; + const char *s; + int i; + + if (e->expr_type != EXPR_CONSTANT) return NULL; - result = transformational_result (array, dim, array->ts.type, - array->ts.kind, &array->where); - init_result_expr (result, 1, NULL); + popcnt = gfc_simplify_popcnt (e); + gcc_assert (popcnt); - return !dim || array->rank == 1 ? - simplify_transformation_to_scalar (result, array, mask, gfc_multiply) : - simplify_transformation_to_array (result, array, dim, mask, gfc_multiply); + s = gfc_extract_int (popcnt, &i); + gcc_assert (!s); + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2); +} + + +gfc_expr * +gfc_simplify_precision (gfc_expr *e) +{ + int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, + gfc_real_kinds[i].precision); +} + + +gfc_expr * +gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, 1, gfc_multiply); } gfc_expr * gfc_simplify_radix (gfc_expr *e) { - gfc_expr *result; int i; - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + switch (e->ts.type) { - case BT_INTEGER: - i = gfc_integer_kinds[i].radix; - break; + case BT_INTEGER: + i = gfc_integer_kinds[i].radix; + break; - case BT_REAL: - i = gfc_real_kinds[i].radix; - break; + case BT_REAL: + i = gfc_real_kinds[i].radix; + break; - default: - gcc_unreachable (); + default: + gcc_unreachable (); } - result = gfc_int_expr (i); - result->where = e->where; - - return result; + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); } gfc_expr * gfc_simplify_range (gfc_expr *e) { - gfc_expr *result; int i; - long j; - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); switch (e->ts.type) { - case BT_INTEGER: - j = gfc_integer_kinds[i].range; - break; + case BT_INTEGER: + i = gfc_integer_kinds[i].range; + break; - case BT_REAL: - case BT_COMPLEX: - j = gfc_real_kinds[i].range; - break; + case BT_REAL: + case BT_COMPLEX: + i = gfc_real_kinds[i].range; + break; - default: - gcc_unreachable (); + default: + gcc_unreachable (); } - result = gfc_int_expr (j); - result->where = e->where; - - return result; + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); } @@ -4155,39 +4752,12 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k) if (e->expr_type != EXPR_CONSTANT) return NULL; - switch (e->ts.type) - { - case BT_INTEGER: - if (!e->is_boz) - result = gfc_int2real (e, kind); - break; - - case BT_REAL: - result = gfc_real2real (e, kind); - break; - - case BT_COMPLEX: - result = gfc_complex2real (e, kind); - break; - - default: - gfc_internal_error ("bad type in REAL"); - /* Not reached */ - } + if (convert_boz (e, kind) == &gfc_bad_expr) + return &gfc_bad_expr; - if (e->ts.type == BT_INTEGER && e->is_boz) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.type = BT_REAL; - ts.kind = kind; - result = gfc_copy_expr (e); - if (!gfc_convert_boz (result, &ts)) - { - gfc_free_expr (result); - return &gfc_bad_expr; - } - } + result = gfc_convert_constant (e, BT_REAL, kind); + if (result == &gfc_bad_expr) + return &gfc_bad_expr; return range_check (result, "REAL"); } @@ -4201,8 +4771,9 @@ gfc_simplify_realpart (gfc_expr *e) if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); mpc_real (result->value.real, e->value.complex, GFC_RND_MODE); + return range_check (result, "REALPART"); } @@ -4303,19 +4874,15 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) len = e->value.character.length; nlen = ncop * len; - result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); + result = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where); if (ncop == 0) - { - result->value.character.string = gfc_get_wide_string (1); - result->value.character.length = 0; - result->value.character.string[0] = '\0'; - return result; - } + return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0); - result->value.character.length = nlen; - result->value.character.string = gfc_get_wide_string (nlen + 1); + len = e->value.character.length; + nlen = ncop * len; + result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen); for (i = 0; i < ncop; i++) for (j = 0; j < len; j++) result->value.character.string[j+i*len]= e->value.character.string[j]; @@ -4333,11 +4900,10 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, { int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS]; int i, rank, npad, x[GFC_MAX_DIMENSIONS]; - gfc_constructor *head, *tail; mpz_t index, size; unsigned long j; size_t nsource; - gfc_expr *e; + gfc_expr *e, *result; /* Check that argument expression types are OK. */ if (!is_constant_array_expr (source) @@ -4350,11 +4916,10 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, mpz_init (index); rank = 0; - head = tail = NULL; for (;;) { - e = gfc_get_array_element (shape_exp, rank); + e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank); if (e == NULL) break; @@ -4363,7 +4928,6 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS); gcc_assert (shape[rank] >= 0); - gfc_free_expr (e); rank++; } @@ -4382,11 +4946,10 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, for (i = 0; i < rank; i++) { - e = gfc_get_array_element (order_exp, i); + e = gfc_constructor_lookup_expr (order_exp->value.constructor, i); gcc_assert (e); gfc_extract_int (e, &order[i]); - gfc_free_expr (e); gcc_assert (order[i] >= 1 && order[i] <= rank); order[i]--; @@ -4417,6 +4980,13 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, for (i = 0; i < rank; i++) x[i] = 0; + result = gfc_get_array_expr (source->ts.type, source->ts.kind, + &source->where); + result->rank = rank; + result->shape = gfc_get_shape (rank); + for (i = 0; i < rank; i++) + mpz_init_set_ui (result->shape[i], shape[i]); + while (nsource > 0 || npad > 0) { /* Figure out which element to extract. */ @@ -4435,27 +5005,19 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, j = mpz_get_ui (index); if (j < nsource) - e = gfc_get_array_element (source, j); + e = gfc_constructor_lookup_expr (source->value.constructor, j); else { gcc_assert (npad > 0); j = j - nsource; j = j % npad; - e = gfc_get_array_element (pad, j); + e = gfc_constructor_lookup_expr (pad->value.constructor, j); } gcc_assert (e); - if (head == NULL) - head = tail = gfc_get_constructor (); - else - { - tail->next = gfc_get_constructor (); - tail = tail->next; - } - - tail->where = e->where; - tail->expr = e; + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (e), &e->where); /* Calculate the next element. */ i = 0; @@ -4472,19 +5034,7 @@ inc: mpz_clear (index); - e = gfc_get_expr (); - e->where = source->where; - e->expr_type = EXPR_ARRAY; - e->value.constructor = head; - e->shape = gfc_get_shape (rank); - - for (i = 0; i < rank; i++) - mpz_init_set_ui (e->shape[i], shape[i]); - - e->ts = source->ts; - e->rank = rank; - - return e; + return result; } @@ -4500,8 +5050,7 @@ gfc_simplify_rrspacing (gfc_expr *x) i = gfc_validate_kind (x->ts.type, x->ts.kind, false); - result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); - + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); /* Special case x = -0 and 0. */ @@ -4532,7 +5081,7 @@ gfc_simplify_scale (gfc_expr *x, gfc_expr *i) if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); if (mpfr_sgn (x->value.real) == 0) { @@ -4646,8 +5195,6 @@ gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind) else back = 0; - result = gfc_constant_result (BT_INTEGER, k, &e->where); - len = e->value.character.length; lenc = c->value.character.length; @@ -4680,7 +5227,8 @@ gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind) } } } - mpz_set_ui (result->value.integer, indx); + + result = gfc_get_int_expr (k, &e->where, indx); return range_check (result, "SCAN"); } @@ -4689,7 +5237,6 @@ gfc_expr * gfc_simplify_selected_char_kind (gfc_expr *e) { int kind; - gfc_expr *result; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -4702,10 +5249,7 @@ gfc_simplify_selected_char_kind (gfc_expr *e) else kind = -1; - result = gfc_int_expr (kind); - result->where = e->where; - - return result; + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); } @@ -4713,7 +5257,6 @@ gfc_expr * gfc_simplify_selected_int_kind (gfc_expr *e) { int i, kind, range; - gfc_expr *result; if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL) return NULL; @@ -4728,18 +5271,16 @@ gfc_simplify_selected_int_kind (gfc_expr *e) if (kind == INT_MAX) kind = -1; - result = gfc_int_expr (kind); - result->where = e->where; - - return result; + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); } gfc_expr * -gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q) +gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx) { - int range, precision, i, kind, found_precision, found_range; - gfc_expr *result; + int range, precision, radix, i, kind, found_precision, found_range, + found_radix; + locus *loc = &gfc_current_locus; if (p == NULL) precision = 0; @@ -4748,6 +5289,7 @@ gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q) if (p->expr_type != EXPR_CONSTANT || gfc_extract_int (p, &precision) != NULL) return NULL; + loc = &p->where; } if (q == NULL) @@ -4757,11 +5299,27 @@ gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q) if (q->expr_type != EXPR_CONSTANT || gfc_extract_int (q, &range) != NULL) return NULL; + + if (!loc) + loc = &q->where; + } + + if (rdx == NULL) + radix = 0; + else + { + if (rdx->expr_type != EXPR_CONSTANT + || gfc_extract_int (rdx, &radix) != NULL) + return NULL; + + if (!loc) + loc = &rdx->where; } kind = INT_MAX; found_precision = 0; found_range = 0; + found_radix = 0; for (i = 0; gfc_real_kinds[i].kind != 0; i++) { @@ -4771,25 +5329,30 @@ gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q) if (gfc_real_kinds[i].range >= range) found_range = 1; + if (gfc_real_kinds[i].radix >= radix) + found_radix = 1; + if (gfc_real_kinds[i].precision >= precision - && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind) + && gfc_real_kinds[i].range >= range + && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind) kind = gfc_real_kinds[i].kind; } if (kind == INT_MAX) { - kind = 0; - - if (!found_precision) + if (found_radix && found_range && !found_precision) kind = -1; - if (!found_range) - kind -= 2; + else if (found_radix && found_precision && !found_range) + kind = -2; + else if (found_radix && !found_precision && !found_range) + kind = -3; + else if (found_radix) + kind = -4; + else + kind = -5; } - result = gfc_int_expr (kind); - result->where = (p != NULL) ? p->where : q->where; - - return result; + return gfc_get_int_expr (gfc_default_integer_kind, loc, kind); } @@ -4803,7 +5366,7 @@ gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); if (mpfr_sgn (x->value.real) == 0) { @@ -4849,23 +5412,33 @@ gfc_simplify_shape (gfc_expr *source) gfc_try t; if (source->rank == 0) - return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind, - &source->where); - - if (source->expr_type != EXPR_VARIABLE) - return NULL; - - result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind, - &source->where); + return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, + &source->where); - ar = gfc_find_array_ref (source); + result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, + &source->where); - t = gfc_array_ref_shape (ar, shape); + if (source->expr_type == EXPR_VARIABLE) + { + ar = gfc_find_array_ref (source); + t = gfc_array_ref_shape (ar, shape); + } + else if (source->shape) + { + t = SUCCESS; + for (n = 0; n < source->rank; n++) + { + mpz_init (shape[n]); + mpz_set (shape[n], source->shape[n]); + } + } + else + t = FAILURE; for (n = 0; n < source->rank; n++) { - e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, - &source->where); + e = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &source->where); if (t == SUCCESS) { @@ -4884,12 +5457,10 @@ gfc_simplify_shape (gfc_expr *source) return NULL; } else - { - e = f; - } + e = f; } - gfc_append_constructor (result, e); + gfc_constructor_append_expr (&result->value.constructor, e, NULL); } return result; @@ -4900,13 +5471,62 @@ gfc_expr * gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { mpz_t size; - gfc_expr *result; int d; int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind); if (k == -1) return &gfc_bad_expr; + /* For unary operations, the size of the result is given by the size + of the operand. For binary ones, it's the size of the first operand + unless it is scalar, then it is the size of the second. */ + if (array->expr_type == EXPR_OP && !array->value.op.uop) + { + gfc_expr* replacement; + gfc_expr* simplified; + + switch (array->value.op.op) + { + /* Unary operations. */ + case INTRINSIC_NOT: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + replacement = array->value.op.op1; + break; + + /* Binary operations. If any one of the operands is scalar, take + the other one's size. If both of them are arrays, it does not + matter -- try to find one with known shape, if possible. */ + default: + if (array->value.op.op1->rank == 0) + replacement = array->value.op.op2; + else if (array->value.op.op2->rank == 0) + replacement = array->value.op.op1; + else + { + simplified = gfc_simplify_size (array->value.op.op1, dim, kind); + if (simplified) + return simplified; + + replacement = array->value.op.op2; + } + break; + } + + /* Try to reduce it directly if possible. */ + simplified = gfc_simplify_size (replacement, dim, kind); + + /* Otherwise, we build a new SIZE call. This is hopefully at least + simpler than the original one. */ + if (!simplified) + simplified = gfc_build_intrinsic_call ("size", array->where, 3, + gfc_copy_expr (replacement), + gfc_copy_expr (dim), + gfc_copy_expr (kind)); + + return simplified; + } + if (dim == NULL) { if (gfc_array_size (array, &size) == FAILURE) @@ -4922,9 +5542,7 @@ gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) return NULL; } - result = gfc_constant_result (BT_INTEGER, k, &array->where); - mpz_set (result->value.integer, size); - return result; + return gfc_get_int_expr (k, &array->where, mpz_get_si (size)); } @@ -4936,27 +5554,27 @@ gfc_simplify_sign (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); switch (x->ts.type) { - case BT_INTEGER: - mpz_abs (result->value.integer, x->value.integer); - if (mpz_sgn (y->value.integer) < 0) - mpz_neg (result->value.integer, result->value.integer); - break; + case BT_INTEGER: + mpz_abs (result->value.integer, x->value.integer); + if (mpz_sgn (y->value.integer) < 0) + mpz_neg (result->value.integer, result->value.integer); + break; - case BT_REAL: - if (gfc_option.flag_sign_zero) - mpfr_copysign (result->value.real, x->value.real, y->value.real, - GFC_RND_MODE); - else - mpfr_setsign (result->value.real, x->value.real, - mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE); - break; + case BT_REAL: + if (gfc_option.flag_sign_zero) + mpfr_copysign (result->value.real, x->value.real, y->value.real, + GFC_RND_MODE); + else + mpfr_setsign (result->value.real, x->value.real, + mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE); + break; - default: - gfc_internal_error ("Bad type in gfc_simplify_sign"); + default: + gfc_internal_error ("Bad type in gfc_simplify_sign"); } return result; @@ -4971,21 +5589,21 @@ gfc_simplify_sin (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); switch (x->ts.type) { - case BT_REAL: - mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE); - break; + case BT_REAL: + mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE); + break; - case BT_COMPLEX: - gfc_set_model (x->value.real); - mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; + case BT_COMPLEX: + gfc_set_model (x->value.real); + mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; - default: - gfc_internal_error ("in gfc_simplify_sin(): Bad type"); + default: + gfc_internal_error ("in gfc_simplify_sin(): Bad type"); } return range_check (result, "SIN"); @@ -5000,15 +5618,21 @@ gfc_simplify_sinh (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - if (x->ts.type == BT_REAL) - mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE); - else if (x->ts.type == BT_COMPLEX) - mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - else - gcc_unreachable (); + switch (x->ts.type) + { + case BT_REAL: + mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE); + break; + case BT_COMPLEX: + mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gcc_unreachable (); + } return range_check (result, "SINH"); } @@ -5042,7 +5666,7 @@ gfc_simplify_spacing (gfc_expr *x) i = gfc_validate_kind (x->ts.type, x->ts.kind, false); - result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); /* Special case x = 0 and -0. */ mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); @@ -5106,31 +5730,29 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp { gcc_assert (dim == 0); - result = gfc_start_constructor (source->ts.type, - source->ts.kind, - &source->where); + result = gfc_get_array_expr (source->ts.type, source->ts.kind, + &source->where); result->rank = 1; result->shape = gfc_get_shape (result->rank); mpz_init_set_si (result->shape[0], ncopies); for (i = 0; i < ncopies; ++i) - gfc_append_constructor (result, gfc_copy_expr (source)); + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (source), NULL); } else if (source->expr_type == EXPR_ARRAY) { - int result_size, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS]; - gfc_constructor *ctor, *source_ctor, *result_ctor; + int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS]; + gfc_constructor *source_ctor; gcc_assert (source->rank < GFC_MAX_DIMENSIONS); gcc_assert (dim >= 0 && dim <= source->rank); - result = gfc_start_constructor (source->ts.type, - source->ts.kind, - &source->where); + result = gfc_get_array_expr (source->ts.type, source->ts.kind, + &source->where); result->rank = source->rank + 1; result->shape = gfc_get_shape (result->rank); - result_size = 1; for (i = 0, j = 0; i < result->rank; ++i) { if (i != dim) @@ -5140,26 +5762,18 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp extent[i] = mpz_get_si (result->shape[i]); rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1]; - result_size *= extent[i]; } - for (i = 0; i < result_size; ++i) - gfc_append_constructor (result, NULL); - - source_ctor = source->value.constructor; - result_ctor = result->value.constructor; - while (source_ctor) + offset = 0; + for (source_ctor = gfc_constructor_first (source->value.constructor); + source_ctor; source_ctor = gfc_constructor_next (source_ctor)) { - ctor = result_ctor; - for (i = 0; i < ncopies; ++i) - { - ctor->expr = gfc_copy_expr (source_ctor->expr); - ADVANCE (ctor, rstride[dim]); - } + gfc_constructor_insert_expr (&result->value.constructor, + gfc_copy_expr (source_ctor->expr), + NULL, offset + i * rstride[dim]); - ADVANCE (result_ctor, (dim == 0 ? ncopies : 1)); - ADVANCE (source_ctor, 1); + offset += (dim == 0 ? ncopies : 1); } } else @@ -5178,61 +5792,43 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp gfc_expr * gfc_simplify_sqrt (gfc_expr *e) { - gfc_expr *result; + gfc_expr *result = NULL; if (e->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); - switch (e->ts.type) { - case BT_REAL: - if (mpfr_cmp_si (e->value.real, 0) < 0) - goto negative_arg; - mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE); + case BT_REAL: + if (mpfr_cmp_si (e->value.real, 0) < 0) + { + gfc_error ("Argument of SQRT at %L has a negative value", + &e->where); + return &gfc_bad_expr; + } + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); + mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE); + break; - break; + case BT_COMPLEX: + gfc_set_model (e->value.real); - case BT_COMPLEX: - gfc_set_model (e->value.real); - mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE); - break; + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); + mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE); + break; - default: - gfc_internal_error ("invalid argument of SQRT at %L", &e->where); + default: + gfc_internal_error ("invalid argument of SQRT at %L", &e->where); } return range_check (result, "SQRT"); - -negative_arg: - gfc_free_expr (result); - gfc_error ("Argument of SQRT at %L has a negative value", &e->where); - return &gfc_bad_expr; } gfc_expr * gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) { - gfc_expr *result; - - if (!is_constant_array_expr (array) - || !gfc_is_constant_expr (dim)) - return NULL; - - if (mask - && !is_constant_array_expr (mask) - && mask->expr_type != EXPR_CONSTANT) - return NULL; - - result = transformational_result (array, dim, array->ts.type, - array->ts.kind, &array->where); - init_result_expr (result, 0, NULL); - - return !dim || array->rank == 1 ? - simplify_transformation_to_scalar (result, array, mask, gfc_add) : - simplify_transformation_to_array (result, array, dim, mask, gfc_add); + return simplify_transformation (array, dim, mask, 0, gfc_add); } @@ -5244,14 +5840,21 @@ gfc_simplify_tan (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - if (x->ts.type == BT_REAL) - mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE); - else if (x->ts.type == BT_COMPLEX) - mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - else - gcc_unreachable (); + switch (x->ts.type) + { + case BT_REAL: + mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gcc_unreachable (); + } return range_check (result, "TAN"); } @@ -5265,17 +5868,23 @@ gfc_simplify_tanh (gfc_expr *x) if (x->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - if (x->ts.type == BT_REAL) - mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE); - else if (x->ts.type == BT_COMPLEX) - mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - else - gcc_unreachable (); + switch (x->ts.type) + { + case BT_REAL: + mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE); + break; - return range_check (result, "TANH"); + case BT_COMPLEX: + mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + default: + gcc_unreachable (); + } + + return range_check (result, "TANH"); } @@ -5287,7 +5896,7 @@ gfc_simplify_tiny (gfc_expr *e) i = gfc_validate_kind (BT_REAL, e->ts.kind, false); - result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); return result; @@ -5297,7 +5906,6 @@ gfc_simplify_tiny (gfc_expr *e) gfc_expr * gfc_simplify_trailz (gfc_expr *e) { - gfc_expr *result; unsigned long tz, bs; int i; @@ -5308,10 +5916,8 @@ gfc_simplify_trailz (gfc_expr *e) bs = gfc_integer_kinds[i].bit_size; tz = mpz_scan1 (e->value.integer, 0); - result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where); - mpz_set_ui (result->value.integer, MIN (tz, bs)); - - return result; + return gfc_get_int_expr (gfc_default_integer_kind, + &e->where, MIN (tz, bs)); } @@ -5328,7 +5934,7 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) unsigned char *buffer; if (!gfc_is_constant_expr (source) - || (gfc_init_expr && !gfc_is_constant_expr (mold)) + || (gfc_init_expr_flag && !gfc_is_constant_expr (mold)) || !gfc_is_constant_expr (size)) return NULL; @@ -5343,12 +5949,12 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) source_size = gfc_target_expr_size (source); /* Create an empty new expression with the appropriate characteristics. */ - result = gfc_constant_result (mold->ts.type, mold->ts.kind, - &source->where); + result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind, + &source->where); result->ts = mold->ts; mold_element = mold->expr_type == EXPR_ARRAY - ? mold->value.constructor->expr + ? gfc_constructor_first (mold->value.constructor)->expr : mold; /* Set result character length, if needed. Note that this needs to be @@ -5415,16 +6021,16 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) gfc_expr * gfc_simplify_transpose (gfc_expr *matrix) { - int i, matrix_rows; + int row, matrix_rows, col, matrix_cols; gfc_expr *result; - gfc_constructor *matrix_ctor; if (!is_constant_array_expr (matrix)) return NULL; gcc_assert (matrix->rank == 2); - result = gfc_start_constructor (matrix->ts.type, matrix->ts.kind, &matrix->where); + result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind, + &matrix->where); result->rank = 2; result->shape = gfc_get_shape (result->rank); mpz_set (result->shape[0], matrix->shape[1]); @@ -5434,20 +6040,16 @@ gfc_simplify_transpose (gfc_expr *matrix) result->ts.u.cl = matrix->ts.u.cl; matrix_rows = mpz_get_si (matrix->shape[0]); - matrix_ctor = matrix->value.constructor; - for (i = 0; i < matrix_rows; ++i) - { - gfc_constructor *column_ctor = matrix_ctor; - while (column_ctor) - { - gfc_append_constructor (result, - gfc_copy_expr (column_ctor->expr)); - - ADVANCE (column_ctor, matrix_rows); - } - - ADVANCE (matrix_ctor, 1); - } + matrix_cols = mpz_get_si (matrix->shape[1]); + for (row = 0; row < matrix_rows; ++row) + for (col = 0; col < matrix_cols; ++col) + { + gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor, + col * matrix_rows + row); + gfc_constructor_insert_expr (&result->value.constructor, + gfc_copy_expr (e), &matrix->where, + row * matrix_cols + col); + } return result; } @@ -5463,9 +6065,6 @@ gfc_simplify_trim (gfc_expr *e) return NULL; len = e->value.character.length; - - result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); - for (count = 0, i = 1; i <= len; ++i) { if (e->value.character.string[len - i] == ' ') @@ -5476,15 +6075,233 @@ gfc_simplify_trim (gfc_expr *e) lentrim = len - count; - result->value.character.length = lentrim; - result->value.character.string = gfc_get_wide_string (lentrim + 1); - + result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim); for (i = 0; i < lentrim; i++) result->value.character.string[i] = e->value.character.string[i]; - result->value.character.string[lentrim] = '\0'; /* For debugger */ + return result; +} + + +gfc_expr * +gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) +{ + gfc_expr *result; + gfc_ref *ref; + gfc_array_spec *as; + gfc_constructor *sub_cons; + bool first_image; + int d; + + if (!is_constant_array_expr (sub)) + goto not_implemented; /* return NULL;*/ + + /* Follow any component references. */ + as = coarray->symtree->n.sym->as; + for (ref = coarray->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + as = ref->u.ar.as; + + if (as->type == AS_DEFERRED) + goto not_implemented; /* return NULL;*/ + + /* "valid sequence of cosubscripts" are required; thus, return 0 unless + the cosubscript addresses the first image. */ + + sub_cons = gfc_constructor_first (sub->value.constructor); + first_image = true; + + for (d = 1; d <= as->corank; d++) + { + gfc_expr *ca_bound; + int cmp; + + if (sub_cons == NULL) + { + gfc_error ("Too few elements in expression for SUB= argument at %L", + &sub->where); + return &gfc_bad_expr; + } + + ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, + NULL, true); + if (ca_bound == NULL) + goto not_implemented; /* return NULL */ + + if (ca_bound == &gfc_bad_expr) + return ca_bound; + + cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer); + + if (cmp == 0) + { + gfc_free_expr (ca_bound); + sub_cons = gfc_constructor_next (sub_cons); + continue; + } + + first_image = false; + + if (cmp > 0) + { + gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " + "SUB has %ld and COARRAY lower bound is %ld)", + &coarray->where, d, + mpz_get_si (sub_cons->expr->value.integer), + mpz_get_si (ca_bound->value.integer)); + gfc_free_expr (ca_bound); + return &gfc_bad_expr; + } + + gfc_free_expr (ca_bound); + + /* Check whether upperbound is valid for the multi-images case. */ + if (d < as->corank) + { + ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as, + NULL, true); + if (ca_bound == &gfc_bad_expr) + return ca_bound; + + if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT + && mpz_cmp (ca_bound->value.integer, + sub_cons->expr->value.integer) < 0) + { + gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " + "SUB has %ld and COARRAY upper bound is %ld)", + &coarray->where, d, + mpz_get_si (sub_cons->expr->value.integer), + mpz_get_si (ca_bound->value.integer)); + gfc_free_expr (ca_bound); + return &gfc_bad_expr; + } + + if (ca_bound) + gfc_free_expr (ca_bound); + } + + sub_cons = gfc_constructor_next (sub_cons); + } + + if (sub_cons != NULL) + { + gfc_error ("Too many elements in expression for SUB= argument at %L", + &sub->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &gfc_current_locus); + if (first_image) + mpz_set_si (result->value.integer, 1); + else + mpz_set_si (result->value.integer, 0); return result; + +not_implemented: + gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant " + "cobounds at %L", &coarray->where); + return &gfc_bad_expr; +} + + +gfc_expr * +gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) +{ + gfc_ref *ref; + gfc_array_spec *as; + int d; + + if (coarray == NULL) + { + gfc_expr *result; + /* FIXME: gfc_current_locus is wrong. */ + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &gfc_current_locus); + mpz_set_si (result->value.integer, 1); + return result; + } + + gcc_assert (coarray->expr_type == EXPR_VARIABLE); + + /* Follow any component references. */ + as = coarray->symtree->n.sym->as; + for (ref = coarray->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + as = ref->u.ar.as; + + if (as->type == AS_DEFERRED) + goto not_implemented; /* return NULL;*/ + + if (dim == NULL) + { + /* Multi-dimensional bounds. */ + gfc_expr *bounds[GFC_MAX_DIMENSIONS]; + gfc_expr *e; + + /* Simplify the bounds for each dimension. */ + for (d = 0; d < as->corank; d++) + { + bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0, + as, NULL, true); + if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) + { + int j; + + for (j = 0; j < d; j++) + gfc_free_expr (bounds[j]); + if (bounds[d] == NULL) + goto not_implemented; + return bounds[d]; + } + } + + /* Allocate the result expression. */ + e = gfc_get_expr (); + e->where = coarray->where; + e->expr_type = EXPR_ARRAY; + e->ts.type = BT_INTEGER; + e->ts.kind = gfc_default_integer_kind; + + e->rank = 1; + e->shape = gfc_get_shape (1); + mpz_init_set_ui (e->shape[0], as->corank); + + /* Create the constructor for this array. */ + for (d = 0; d < as->corank; d++) + gfc_constructor_append_expr (&e->value.constructor, + bounds[d], &e->where); + + return e; + } + else + { + gfc_expr *e; + /* A DIM argument is specified. */ + if (dim->expr_type != EXPR_CONSTANT) + goto not_implemented; /*return NULL;*/ + + d = mpz_get_si (dim->value.integer); + + if (d < 1 || d > as->corank) + { + gfc_error ("DIM argument at %L is out of bounds", &dim->where); + return &gfc_bad_expr; + } + + /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/ + e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true); + if (e != NULL) + return e; + else + goto not_implemented; + } + +not_implemented: + gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant " + "cobounds at %L", &coarray->where); + return &gfc_bad_expr; } @@ -5494,6 +6311,21 @@ gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) return simplify_bound (array, dim, kind, 1); } +gfc_expr * +gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + gfc_expr *e; + /* return simplify_cobound (array, dim, kind, 1);*/ + + e = simplify_cobound (array, dim, kind, 1); + if (e != NULL) + return e; + + gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant " + "cobounds at %L", &array->where); + return &gfc_bad_expr; +} + gfc_expr * gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) @@ -5507,18 +6339,20 @@ gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) && !is_constant_array_expr(field))) return NULL; - result = gfc_start_constructor (vector->ts.type, - vector->ts.kind, - &vector->where); + result = gfc_get_array_expr (vector->ts.type, vector->ts.kind, + &vector->where); result->rank = mask->rank; result->shape = gfc_copy_shape (mask->shape, mask->rank); if (vector->ts.type == BT_CHARACTER) result->ts.u.cl = vector->ts.u.cl; - vector_ctor = vector->value.constructor; - mask_ctor = mask->value.constructor; - field_ctor = field->expr_type == EXPR_ARRAY ? field->value.constructor : NULL; + vector_ctor = gfc_constructor_first (vector->value.constructor); + mask_ctor = gfc_constructor_first (mask->value.constructor); + field_ctor + = field->expr_type == EXPR_ARRAY + ? gfc_constructor_first (field->value.constructor) + : NULL; while (mask_ctor) { @@ -5526,17 +6360,17 @@ gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) { gcc_assert (vector_ctor); e = gfc_copy_expr (vector_ctor->expr); - ADVANCE (vector_ctor, 1); + vector_ctor = gfc_constructor_next (vector_ctor); } else if (field->expr_type == EXPR_ARRAY) e = gfc_copy_expr (field_ctor->expr); else e = gfc_copy_expr (field); - gfc_append_constructor (result, e); + gfc_constructor_append_expr (&result->value.constructor, e, NULL); - ADVANCE (mask_ctor, 1); - ADVANCE (field_ctor, 1); + mask_ctor = gfc_constructor_next (mask_ctor); + field_ctor = gfc_constructor_next (field_ctor); } return result; @@ -5563,7 +6397,7 @@ gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind) else back = 0; - result = gfc_constant_result (BT_INTEGER, k, &s->where); + result = gfc_get_constant_expr (BT_INTEGER, k, &s->where); len = s->value.character.length; lenset = set->value.character.length; @@ -5623,20 +6457,22 @@ gfc_simplify_xor (gfc_expr *x, gfc_expr *y) return NULL; kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - if (x->ts.type == BT_INTEGER) - { - result = gfc_constant_result (BT_INTEGER, kind, &x->where); - mpz_xor (result->value.integer, x->value.integer, y->value.integer); - return range_check (result, "XOR"); - } - else /* BT_LOGICAL */ + + switch (x->ts.type) { - result = gfc_constant_result (BT_LOGICAL, kind, &x->where); - result->value.logical = (x->value.logical && !y->value.logical) - || (!x->value.logical && y->value.logical); - return result; - } + case BT_INTEGER: + result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); + mpz_xor (result->value.integer, x->value.integer, y->value.integer); + return range_check (result, "XOR"); + + case BT_LOGICAL: + return gfc_get_logical_expr (kind, &x->where, + (x->value.logical && !y->value.logical) + || (!x->value.logical && y->value.logical)); + default: + gcc_unreachable (); + } } @@ -5651,7 +6487,7 @@ gfc_expr * gfc_convert_constant (gfc_expr *e, bt type, int kind) { gfc_expr *g, *result, *(*f) (gfc_expr *, int); - gfc_constructor *head, *c, *tail = NULL; + gfc_constructor *c; switch (e->ts.type) { @@ -5771,45 +6607,37 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind) if (!gfc_is_constant_expr (e)) break; - head = NULL; + result = gfc_get_array_expr (type, kind, &e->where); + result->shape = gfc_copy_shape (e->shape, e->rank); + result->rank = e->rank; - for (c = e->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) { - if (head == NULL) - head = tail = gfc_get_constructor (); - else - { - tail->next = gfc_get_constructor (); - tail = tail->next; - } - - tail->where = c->where; - + gfc_expr *tmp; if (c->iterator == NULL) - tail->expr = f (c->expr, kind); + tmp = f (c->expr, kind); else { g = gfc_convert_constant (c->expr, type, kind); if (g == &gfc_bad_expr) - return g; - tail->expr = g; + { + gfc_free_expr (result); + return g; + } + tmp = g; } - if (tail->expr == NULL) + if (tmp == NULL) { - gfc_free_constructor (head); + gfc_free_expr (result); return NULL; } + + gfc_constructor_append_expr (&result->value.constructor, + tmp, &c->where); } - result = gfc_get_expr (); - result->ts.type = type; - result->ts.kind = kind; - result->expr_type = EXPR_ARRAY; - result->value.constructor = head; - result->shape = gfc_copy_shape (e->shape, e->rank); - result->where = e->where; - result->rank = e->rank; break; default: @@ -5833,7 +6661,7 @@ gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind) if (e->expr_type == EXPR_CONSTANT) { /* Simple case of a scalar. */ - result = gfc_constant_result (BT_CHARACTER, kind, &e->where); + result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where); if (result == NULL) return &gfc_bad_expr; @@ -5860,42 +6688,32 @@ gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind) else if (e->expr_type == EXPR_ARRAY) { /* For an array constructor, we convert each constructor element. */ - gfc_constructor *head = NULL, *tail = NULL, *c; + gfc_constructor *c; - for (c = e->value.constructor; c; c = c->next) - { - if (head == NULL) - head = tail = gfc_get_constructor (); - else - { - tail->next = gfc_get_constructor (); - tail = tail->next; - } + result = gfc_get_array_expr (type, kind, &e->where); + result->shape = gfc_copy_shape (e->shape, e->rank); + result->rank = e->rank; + result->ts.u.cl = e->ts.u.cl; - tail->where = c->where; - tail->expr = gfc_convert_char_constant (c->expr, type, kind); - if (tail->expr == &gfc_bad_expr) + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + { + gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind); + if (tmp == &gfc_bad_expr) { - tail->expr = NULL; + gfc_free_expr (result); return &gfc_bad_expr; } - if (tail->expr == NULL) + if (tmp == NULL) { - gfc_free_constructor (head); + gfc_free_expr (result); return NULL; } - } - result = gfc_get_expr (); - result->ts.type = type; - result->ts.kind = kind; - result->expr_type = EXPR_ARRAY; - result->value.constructor = head; - result->shape = gfc_copy_shape (e->shape, e->rank); - result->where = e->where; - result->rank = e->rank; - result->ts.u.cl = e->ts.u.cl; + gfc_constructor_append_expr (&result->value.constructor, + tmp, &c->where); + } return result; } diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index ffef22d1140..f9ad5d82793 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -116,7 +116,8 @@ gfc_free_statement (gfc_code *p) break; case EXEC_BLOCK: - gfc_free_namespace (p->ext.ns); + gfc_free_namespace (p->ext.block.ns); + gfc_free_association_list (p->ext.block.assoc); break; case EXEC_COMPCALL: @@ -231,3 +232,15 @@ gfc_free_statements (gfc_code *p) } } + +/* Free an association list (of an ASSOCIATE statement). */ + +void +gfc_free_association_list (gfc_association_list* assoc) +{ + if (!assoc) + return; + + gfc_free_association_list (assoc->next); + gfc_free (assoc); +} diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 98af7550f22..b4fc82c6ac9 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -27,6 +27,7 @@ along with GCC; see the file COPYING3. If not see #include "gfortran.h" #include "parse.h" #include "match.h" +#include "constructor.h" /* Strings for all symbol attributes. We use these for dumping the @@ -371,7 +372,8 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE", *volatile_ = "VOLATILE", *is_protected = "PROTECTED", *is_bind_c = "BIND(C)", *procedure = "PROCEDURE", - *asynchronous = "ASYNCHRONOUS"; + *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION", + *contiguous = "CONTIGUOUS"; static const char *threadprivate = "THREADPRIVATE"; const char *a1, *a2; @@ -477,11 +479,13 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (in_common, dummy); conf (in_common, allocatable); + conf (in_common, codimension); conf (in_common, result); conf (dummy, result); conf (in_equivalence, use_assoc); + conf (in_equivalence, codimension); conf (in_equivalence, dummy); conf (in_equivalence, target); conf (in_equivalence, pointer); @@ -503,6 +507,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (is_bind_c, cray_pointer); conf (is_bind_c, cray_pointee); + conf (is_bind_c, codimension); conf (is_bind_c, allocatable); conf (is_bind_c, elemental); @@ -513,6 +518,8 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) /* Cray pointer/pointee conflicts. */ conf (cray_pointer, cray_pointee); conf (cray_pointer, dimension); + conf (cray_pointer, codimension); + conf (cray_pointer, contiguous); conf (cray_pointer, pointer); conf (cray_pointer, target); conf (cray_pointer, allocatable); @@ -524,6 +531,8 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (cray_pointer, entry); conf (cray_pointee, allocatable); + conf (cray_pointer, contiguous); + conf (cray_pointer, codimension); conf (cray_pointee, intent); conf (cray_pointee, optional); conf (cray_pointee, dummy); @@ -539,7 +548,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (data, function); conf (data, result); conf (data, allocatable); - conf (data, use_assoc); conf (value, pointer) conf (value, allocatable) @@ -547,8 +555,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (value, function) conf (value, volatile_) conf (value, dimension) + conf (value, codimension) conf (value, external) + conf (codimension, result) + if (attr->value && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT)) { @@ -558,7 +569,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) } conf (is_protected, intrinsic) - conf (is_protected, external) conf (is_protected, in_common) conf (asynchronous, intrinsic) @@ -576,8 +586,8 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (procedure, allocatable) conf (procedure, dimension) + conf (procedure, codimension) conf (procedure, intrinsic) - conf (procedure, is_protected) conf (procedure, target) conf (procedure, value) conf (procedure, volatile_) @@ -601,10 +611,12 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) case FL_BLOCK_DATA: case FL_MODULE: case FL_LABEL: + conf2 (codimension); conf2 (dimension); conf2 (dummy); conf2 (volatile_); conf2 (asynchronous); + conf2 (contiguous); conf2 (pointer); conf2 (is_protected); conf2 (target); @@ -653,6 +665,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (volatile_); conf2 (asynchronous); conf2 (in_namelist); + conf2 (codimension); conf2 (dimension); conf2 (function); conf2 (threadprivate); @@ -711,6 +724,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (function); conf2 (subroutine); conf2 (entry); + conf2 (contiguous); conf2 (pointer); conf2 (is_protected); conf2 (target); @@ -722,6 +736,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (threadprivate); conf2 (value); conf2 (is_bind_c); + conf2 (codimension); conf2 (result); break; @@ -866,6 +881,32 @@ gfc_add_allocatable (symbol_attribute *attr, locus *where) gfc_try +gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return FAILURE; + + if (attr->codimension) + { + duplicate_attr ("CODIMENSION", where); + return FAILURE; + } + + if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY + && gfc_find_state (COMP_INTERFACE) == FAILURE) + { + gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body " + "at %L", name, where); + return FAILURE; + } + + attr->codimension = 1; + return check_conflict (attr, name, where); +} + + +gfc_try gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where) { @@ -892,6 +933,18 @@ gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where) gfc_try +gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return FAILURE; + + attr->contiguous = 1; + return check_conflict (attr, name, where); +} + + +gfc_try gfc_add_external (symbol_attribute *attr, locus *where) { @@ -1042,13 +1095,14 @@ gfc_add_result (symbol_attribute *attr, const char *name, locus *where) gfc_try -gfc_add_save (symbol_attribute *attr, const char *name, locus *where) +gfc_add_save (symbol_attribute *attr, save_state s, const char *name, + locus *where) { if (check_used (attr, name, where)) return FAILURE; - if (gfc_pure (NULL)) + if (s == SAVE_EXPLICIT && gfc_pure (NULL)) { gfc_error ("SAVE attribute at %L cannot be specified in a PURE procedure", @@ -1056,7 +1110,7 @@ gfc_add_save (symbol_attribute *attr, const char *name, locus *where) return FAILURE; } - if (attr->save == SAVE_EXPLICIT && !attr->vtab) + if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT) { if (gfc_notify_std (GFC_STD_LEGACY, "Duplicate SAVE attribute specified at %L", @@ -1065,7 +1119,7 @@ gfc_add_save (symbol_attribute *attr, const char *name, locus *where) return FAILURE; } - attr->save = SAVE_EXPLICIT; + attr->save = s; return check_conflict (attr, name, where); } @@ -1096,7 +1150,7 @@ gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where) { /* No check_used needed as 11.2.1 of the F2003 standard allows that the local identifier made accessible by a use statement can be - given a VOLATILE attribute. */ + given a VOLATILE attribute - unless it is a coarray (F2008, C560). */ if (attr->volatile_ && attr->volatile_ns == gfc_current_ns) if (gfc_notify_std (GFC_STD_LEGACY, @@ -1677,13 +1731,17 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE) goto fail; + if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE) + goto fail; + if (src->contiguous && gfc_add_contiguous (dest, NULL, where) == FAILURE) + goto fail; if (src->optional && gfc_add_optional (dest, where) == FAILURE) goto fail; if (src->pointer && gfc_add_pointer (dest, where) == FAILURE) goto fail; if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE) goto fail; - if (src->save && gfc_add_save (dest, NULL, where) == FAILURE) + if (src->save && gfc_add_save (dest, src->save, NULL, where) == FAILURE) goto fail; if (src->value && gfc_add_value (dest, NULL, where) == FAILURE) goto fail; @@ -2445,6 +2503,32 @@ gfc_free_symbol (gfc_symbol *sym) } +/* Decrease the reference counter and free memory when we reach zero. */ + +void +gfc_release_symbol (gfc_symbol *sym) +{ + if (sym == NULL) + return; + + if (sym->formal_ns != NULL && sym->refs == 2) + { + /* As formal_ns contains a reference to sym, delete formal_ns just + before the deletion of sym. */ + gfc_namespace *ns = sym->formal_ns; + sym->formal_ns = NULL; + gfc_free_namespace (ns); + } + + sym->refs--; + if (sym->refs > 0) + return; + + gcc_assert (sym->refs == 0); + gfc_free_symbol (sym); +} + + /* Allocate and initialize a new symbol node. */ gfc_symbol * @@ -2474,6 +2558,7 @@ gfc_new_symbol (const char *name, gfc_namespace *ns) /* Clear the ptrs we may need. */ p->common_block = NULL; p->f2k_derived = NULL; + p->assoc = NULL; return p; } @@ -2507,6 +2592,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. */ @@ -2753,6 +2859,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; } @@ -2803,11 +2920,7 @@ gfc_undo_symbols (void) gfc_delete_symtree (&p->ns->sym_root, p->name); - p->refs--; - if (p->refs < 0) - gfc_internal_error ("gfc_undo_symbols(): Negative refs"); - if (p->refs == 0) - gfc_free_symbol (p); + gfc_release_symbol (p); continue; } @@ -3017,35 +3130,13 @@ free_uop_tree (gfc_symtree *uop_tree) static void free_sym_tree (gfc_symtree *sym_tree) { - gfc_namespace *ns; - gfc_symbol *sym; - if (sym_tree == NULL) return; free_sym_tree (sym_tree->left); free_sym_tree (sym_tree->right); - sym = sym_tree->n.sym; - - sym->refs--; - if (sym->refs < 0) - gfc_internal_error ("free_sym_tree(): Negative refs"); - - if (sym->formal_ns != NULL && sym->refs == 1) - { - /* As formal_ns contains a reference to sym, delete formal_ns just - before the deletion of sym. */ - ns = sym->formal_ns; - sym->formal_ns = NULL; - gfc_free_namespace (ns); - } - else if (sym->refs == 0) - { - /* Go ahead and delete the symbol. */ - gfc_free_symbol (sym); - } - + gfc_release_symbol (sym_tree->n.sym); gfc_free (sym_tree); } @@ -3099,13 +3190,7 @@ gfc_free_finalizer (gfc_finalizer* el) { if (el) { - if (el->proc_sym) - { - --el->proc_sym->refs; - if (!el->proc_sym->refs) - gfc_free_symbol (el->proc_sym); - } - + gfc_release_symbol (el->proc_sym); gfc_free (el); } } @@ -3346,7 +3431,7 @@ save_symbol (gfc_symbol *sym) /* Automatic objects are not saved. */ if (gfc_is_var_automatic (sym)) return; - gfc_add_save (&sym->attr, sym->name, &sym->declared_at); + gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at); } @@ -3359,16 +3444,13 @@ gfc_save_all (gfc_namespace *ns) } -#ifdef GFC_DEBUG /* Make sure that no changes to symbols are pending. */ void -gfc_symbol_state(void) { - - if (changed_syms != NULL) - gfc_internal_error("Symbol changes still pending!"); +gfc_enforce_clean_symbol_state(void) +{ + gcc_assert (changed_syms == NULL); } -#endif /************** Global symbol handling ************/ @@ -3624,6 +3706,7 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name, { gfc_symtree *tmp_symtree; gfc_symbol *tmp_sym; + gfc_constructor *c; tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name); @@ -3685,10 +3768,11 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name, tmp_sym->value->expr_type = EXPR_STRUCTURE; tmp_sym->value->ts.type = BT_DERIVED; tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived; - tmp_sym->value->value.constructor = gfc_get_constructor (); - tmp_sym->value->value.constructor->expr = gfc_get_expr (); - tmp_sym->value->value.constructor->expr->expr_type = EXPR_NULL; - tmp_sym->value->value.constructor->expr->ts.is_iso_c = 1; + gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL); + c = gfc_constructor_first (tmp_sym->value->value.constructor); + c->expr = gfc_get_expr (); + c->expr->expr_type = EXPR_NULL; + c->expr->ts.is_iso_c = 1; /* Must declare c_null_ptr and c_null_funptr as having the PARAMETER attribute so they can be used in init expressions. */ tmp_sym->attr.flavor = FL_PARAMETER; @@ -3795,6 +3879,9 @@ gen_cptr_param (gfc_formal_arglist **head, formal_arg = gfc_get_formal_arglist (); /* Add arg to list of formal args (the CPTR arg). */ add_formal_arg (head, tail, formal_arg, param_sym); + + /* Validate changes. */ + gfc_commit_symbol (param_sym); } @@ -3840,6 +3927,9 @@ gen_fptr_param (gfc_formal_arglist **head, formal_arg = gfc_get_formal_arglist (); /* Add arg to list of formal args. */ add_formal_arg (head, tail, formal_arg, param_sym); + + /* Validate changes. */ + gfc_commit_symbol (param_sym); } @@ -3894,7 +3984,8 @@ gen_shape_param (gfc_formal_arglist **head, param_sym->as->upper[i] = NULL; } param_sym->as->rank = 1; - param_sym->as->lower[0] = gfc_int_expr (1); + param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1); /* The extent is unknown until we get it. The length give us the rank the incoming pointer. */ @@ -3911,6 +4002,9 @@ gen_shape_param (gfc_formal_arglist **head, formal_arg = gfc_get_formal_arglist (); /* Add arg to list of formal args. */ add_formal_arg (head, tail, formal_arg, param_sym); + + /* Validate changes. */ + gfc_commit_symbol (param_sym); } @@ -3973,6 +4067,9 @@ gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src) /* Add arg to list of formal args. */ add_formal_arg (&head, &tail, formal_arg, formal_arg->sym); + + /* Validate changes. */ + gfc_commit_symbol (formal_arg->sym); } /* Add the interface to the symbol. */ @@ -4011,6 +4108,7 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src) /* May need to copy more info for the symbol. */ formal_arg->sym->ts = curr_arg->ts; formal_arg->sym->attr.optional = curr_arg->optional; + formal_arg->sym->attr.value = curr_arg->value; formal_arg->sym->attr.intent = curr_arg->intent; formal_arg->sym->attr.flavor = FL_VARIABLE; formal_arg->sym->attr.dummy = 1; @@ -4030,6 +4128,9 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src) /* Add arg to list of formal args. */ add_formal_arg (&head, &tail, formal_arg, formal_arg->sym); + + /* Validate changes. */ + gfc_commit_symbol (formal_arg->sym); } /* Add the interface to the symbol. */ @@ -4083,6 +4184,9 @@ gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src) /* Add arg to list of formal args. */ add_formal_arg (&head, &tail, formal_arg, formal_arg->sym); + + /* Validate changes. */ + gfc_commit_symbol (formal_arg->sym); } /* Add the interface to the symbol. */ @@ -4237,7 +4341,8 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, #define NAMED_CHARKNDCST(a,b,c) case a : #include "iso-c-binding.def" - tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value); + tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, + c_interop_kinds_table[s].value); /* Initialize an integer constant expression node. */ tmp_sym->attr.flavor = FL_PARAMETER; @@ -4267,20 +4372,16 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, /* Initialize an integer constant expression node for the length of the character. */ - tmp_sym->value = gfc_get_expr (); - tmp_sym->value->expr_type = EXPR_CONSTANT; - tmp_sym->value->ts.type = BT_CHARACTER; - tmp_sym->value->ts.kind = gfc_default_character_kind; - tmp_sym->value->where = gfc_current_locus; + tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind, + &gfc_current_locus, NULL, 1); tmp_sym->value->ts.is_c_interop = 1; tmp_sym->value->ts.is_iso_c = 1; tmp_sym->value->value.character.length = 1; - tmp_sym->value->value.character.string = gfc_get_wide_string (2); tmp_sym->value->value.character.string[0] = (gfc_char_t) c_interop_kinds_table[s].value; - tmp_sym->value->value.character.string[1] = '\0'; tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - tmp_sym->ts.u.cl->length = gfc_int_expr (1); + tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1); /* May not need this in both attr and ts, but do need in attr for writing module file. */ @@ -4465,6 +4566,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, default: gcc_unreachable (); } + gfc_commit_symbol (tmp_sym); } @@ -4552,12 +4654,14 @@ gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns, list and marked `error' until symbols are committed. */ gfc_typebound_proc* -gfc_get_typebound_proc (void) +gfc_get_typebound_proc (gfc_typebound_proc *tb0) { gfc_typebound_proc *result; tentative_tbp *list_node; result = XCNEW (gfc_typebound_proc); + if (tb0) + *result = *tb0; result->error = 1; list_node = XCNEW (tentative_tbp); @@ -4620,8 +4724,6 @@ gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2) bool gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) { - gfc_component *cmp1, *cmp2; - bool is_class1 = (ts1->type == BT_CLASS); bool is_class2 = (ts2->type == BT_CLASS); bool is_derived1 = (ts1->type == BT_DERIVED); @@ -4633,368 +4735,48 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) if (is_derived1 && is_derived2) return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); - cmp1 = cmp2 = NULL; - - if (is_class1) - { - cmp1 = gfc_find_component (ts1->u.derived, "$data", true, false); - if (cmp1 == NULL) - return 0; - } - - if (is_class2) - { - cmp2 = gfc_find_component (ts2->u.derived, "$data", true, false); - if (cmp2 == NULL) - return 0; - } - if (is_class1 && is_derived2) - return gfc_type_is_extension_of (cmp1->ts.u.derived, ts2->u.derived); - + return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, + ts2->u.derived); else if (is_class1 && is_class2) - return gfc_type_is_extension_of (cmp1->ts.u.derived, cmp2->ts.u.derived); - + return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, + ts2->u.derived->components->ts.u.derived); else return 0; } -/* Build a polymorphic CLASS entity, using the symbol that comes from - build_sym. A CLASS entity is represented by an encapsulating type, - which contains the declared type as '$data' component, plus a pointer - component '$vptr' which determines the dynamic type. */ - -gfc_try -gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, - gfc_array_spec **as) -{ - char name[GFC_MAX_SYMBOL_LEN + 5]; - gfc_symbol *fclass; - gfc_symbol *vtab; - gfc_component *c; - - /* Determine the name of the encapsulating type. */ - if ((*as) && (*as)->rank && attr->allocatable) - sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank); - else if ((*as) && (*as)->rank) - sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank); - else if (attr->allocatable) - sprintf (name, ".class.%s.a", ts->u.derived->name); - else - sprintf (name, ".class.%s", ts->u.derived->name); - - gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass); - if (fclass == NULL) - { - gfc_symtree *st; - /* If not there, create a new symbol. */ - fclass = gfc_new_symbol (name, ts->u.derived->ns); - st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name); - st->n.sym = fclass; - gfc_set_sym_referenced (fclass); - fclass->refs++; - fclass->ts.type = BT_UNKNOWN; - fclass->attr.abstract = ts->u.derived->attr.abstract; - if (ts->u.derived->f2k_derived) - fclass->f2k_derived = gfc_get_namespace (NULL, 0); - if (gfc_add_flavor (&fclass->attr, FL_DERIVED, - NULL, &gfc_current_locus) == FAILURE) - return FAILURE; - - /* Add component '$data'. */ - if (gfc_add_component (fclass, "$data", &c) == FAILURE) - return FAILURE; - c->ts = *ts; - c->ts.type = BT_DERIVED; - c->attr.access = ACCESS_PRIVATE; - c->ts.u.derived = ts->u.derived; - c->attr.class_pointer = attr->pointer; - c->attr.pointer = attr->pointer || attr->dummy; - c->attr.allocatable = attr->allocatable; - c->attr.dimension = attr->dimension; - c->attr.abstract = ts->u.derived->attr.abstract; - c->as = (*as); - c->initializer = gfc_get_expr (); - c->initializer->expr_type = EXPR_NULL; - - /* Add component '$vptr'. */ - if (gfc_add_component (fclass, "$vptr", &c) == FAILURE) - return FAILURE; - c->ts.type = BT_DERIVED; - vtab = gfc_find_derived_vtab (ts->u.derived); - gcc_assert (vtab); - c->ts.u.derived = vtab->ts.u.derived; - c->attr.pointer = 1; - c->initializer = gfc_get_expr (); - c->initializer->expr_type = EXPR_NULL; - } - - /* Since the extension field is 8 bit wide, we can only have - up to 255 extension levels. */ - if (ts->u.derived->attr.extension == 255) - { - gfc_error ("Maximum extension level reached with type '%s' at %L", - ts->u.derived->name, &ts->u.derived->declared_at); - return FAILURE; - } - - fclass->attr.extension = ts->u.derived->attr.extension + 1; - fclass->attr.is_class = 1; - ts->u.derived = fclass; - attr->allocatable = attr->pointer = attr->dimension = 0; - (*as) = NULL; /* XXX */ - return SUCCESS; -} - - -/* Find the symbol for a derived type's vtab. */ +/* Find the parent-namespace of the current function. If we're inside + BLOCK constructs, it may not be the current one. */ -gfc_symbol * -gfc_find_derived_vtab (gfc_symbol *derived) +gfc_namespace* +gfc_find_proc_namespace (gfc_namespace* ns) { - gfc_namespace *ns; - gfc_symbol *vtab = NULL, *vtype = NULL; - char name[2 * GFC_MAX_SYMBOL_LEN + 8]; - - ns = gfc_current_ns; - - for (; ns; ns = ns->parent) - if (!ns->parent) - break; - - if (ns) - { - sprintf (name, "vtab$%s", derived->name); - gfc_find_symbol (name, ns, 0, &vtab); - - if (vtab == NULL) - { - gfc_get_symbol (name, 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->attr.access = ACCESS_PRIVATE; - vtab->refs++; - gfc_set_sym_referenced (vtab); - sprintf (name, "vtype$%s", derived->name); - - gfc_find_symbol (name, ns, 0, &vtype); - if (vtype == NULL) - { - gfc_component *c; - gfc_symbol *parent = NULL, *parent_vtab = NULL; - - gfc_get_symbol (name, ns, &vtype); - if (gfc_add_flavor (&vtype->attr, FL_DERIVED, - NULL, &gfc_current_locus) == FAILURE) - return NULL; - vtype->refs++; - gfc_set_sym_referenced (vtype); - vtype->attr.access = ACCESS_PRIVATE; - - /* Add component '$hash'. */ - if (gfc_add_component (vtype, "$hash", &c) == FAILURE) - return NULL; - c->ts.type = BT_INTEGER; - c->ts.kind = 4; - c->attr.access = ACCESS_PRIVATE; - c->initializer = gfc_int_expr (derived->hash_value); - - /* Add component '$size'. */ - if (gfc_add_component (vtype, "$size", &c) == FAILURE) - return NULL; - c->ts.type = BT_INTEGER; - c->ts.kind = 4; - c->attr.access = ACCESS_PRIVATE; - /* Remember the derived type in ts.u.derived, - so that the correct initializer can be set later on - (in gfc_conv_structure). */ - c->ts.u.derived = derived; - c->initializer = gfc_int_expr (0); - - /* Add component $extends. */ - if (gfc_add_component (vtype, "$extends", &c) == FAILURE) - return NULL; - c->attr.pointer = 1; - c->attr.access = ACCESS_PRIVATE; - c->initializer = gfc_get_expr (); - parent = gfc_get_derived_super_type (derived); - if (parent) - { - parent_vtab = gfc_find_derived_vtab (parent); - c->ts.type = BT_DERIVED; - c->ts.u.derived = parent_vtab->ts.u.derived; - c->initializer->expr_type = EXPR_VARIABLE; - gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0, - &c->initializer->symtree); - } - else - { - c->ts.type = BT_DERIVED; - c->ts.u.derived = vtype; - c->initializer->expr_type = EXPR_NULL; - } - } - vtab->ts.u.derived = vtype; - - vtab->value = gfc_default_initializer (&vtab->ts); - } - } - - return vtab; -} - - -/* General worker function to find either a type-bound procedure or a - type-bound user operator. */ - -static gfc_symtree* -find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, - const char* name, bool noaccess, bool uop, - locus* where) -{ - gfc_symtree* res; - gfc_symtree* root; - - /* Set correct symbol-root. */ - gcc_assert (derived->f2k_derived); - root = (uop ? derived->f2k_derived->tb_uop_root - : derived->f2k_derived->tb_sym_root); - - /* Set default to failure. */ - if (t) - *t = FAILURE; - - /* Try to find it in the current type's namespace. */ - res = gfc_find_symtree (root, name); - if (res && res->n.tb && !res->n.tb->error) + while (ns->construct_entities) { - /* We found one. */ - if (t) - *t = SUCCESS; - - if (!noaccess && derived->attr.use_assoc - && res->n.tb->access == ACCESS_PRIVATE) - { - if (where) - gfc_error ("'%s' of '%s' is PRIVATE at %L", - name, derived->name, where); - if (t) - *t = FAILURE; - } - - return res; - } - - /* Otherwise, recurse on parent type if derived is an extension. */ - if (derived->attr.extension) - { - gfc_symbol* super_type; - super_type = gfc_get_derived_super_type (derived); - gcc_assert (super_type); - - return find_typebound_proc_uop (super_type, t, name, - noaccess, uop, where); + ns = ns->parent; + gcc_assert (ns); } - /* Nothing found. */ - return NULL; -} - - -/* Find a type-bound procedure or user operator by name for a derived-type - (looking recursively through the super-types). */ - -gfc_symtree* -gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t, - const char* name, bool noaccess, locus* where) -{ - return find_typebound_proc_uop (derived, t, name, noaccess, false, where); -} - -gfc_symtree* -gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t, - const char* name, bool noaccess, locus* where) -{ - return find_typebound_proc_uop (derived, t, name, noaccess, true, where); + return ns; } -/* Find a type-bound intrinsic operator looking recursively through the - super-type hierarchy. */ +/* Check if an associate-variable should be translated as an `implicit' pointer + internally (if it is associated to a variable and not an array with + descriptor). */ -gfc_typebound_proc* -gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, - gfc_intrinsic_op op, bool noaccess, - locus* where) +bool +gfc_is_associate_pointer (gfc_symbol* sym) { - gfc_typebound_proc* res; - - /* Set default to failure. */ - if (t) - *t = FAILURE; - - /* Try to find it in the current type's namespace. */ - if (derived->f2k_derived) - res = derived->f2k_derived->tb_op[op]; - else - res = NULL; - - /* Check access. */ - if (res && !res->error) - { - /* We found one. */ - if (t) - *t = SUCCESS; - - if (!noaccess && derived->attr.use_assoc - && res->access == ACCESS_PRIVATE) - { - if (where) - gfc_error ("'%s' of '%s' is PRIVATE at %L", - gfc_op2string (op), derived->name, where); - if (t) - *t = FAILURE; - } - - return res; - } - - /* Otherwise, recurse on parent type if derived is an extension. */ - if (derived->attr.extension) - { - gfc_symbol* super_type; - super_type = gfc_get_derived_super_type (derived); - gcc_assert (super_type); - - return gfc_find_typebound_intrinsic_op (super_type, t, op, - noaccess, where); - } - - /* Nothing found. */ - return NULL; -} - - -/* Get a typebound-procedure symtree or create and insert it if not yet - present. This is like a very simplified version of gfc_get_sym_tree for - tbp-symtrees rather than regular ones. */ + if (!sym->assoc) + return false; -gfc_symtree* -gfc_get_tbp_symtree (gfc_symtree **root, const char *name) -{ - gfc_symtree *result; + if (!sym->assoc->variable) + return false; - result = gfc_find_symtree (*root, name); - if (!result) - { - result = gfc_new_symtree (root, name); - gcc_assert (result); - result->n.tb = NULL; - } + if (sym->attr.dimension && sym->as->type != AS_EXPLICIT) + return false; - return result; + return true; } diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c index 19b24c509ed..93e1c8c89bb 100644 --- a/gcc/fortran/target-memory.c +++ b/gcc/fortran/target-memory.c @@ -1,5 +1,5 @@ /* Simulate storage of variables into target memory. - Copyright (C) 2007, 2008, 2009 + Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Paul Thomas and Brooks Moses @@ -26,6 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "tree.h" #include "gfortran.h" #include "arith.h" +#include "constructor.h" #include "trans.h" #include "trans-const.h" #include "trans-types.h" @@ -38,7 +39,8 @@ static size_t size_array (gfc_expr *e) { mpz_t array_size; - size_t elt_size = gfc_target_expr_size (e->value.constructor->expr); + gfc_constructor *c = gfc_constructor_first (e->value.constructor); + size_t elt_size = gfc_target_expr_size (c->expr); gfc_array_size (e, &array_size); return (size_t)mpz_get_ui (array_size) * elt_size; @@ -134,10 +136,12 @@ encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size) int i; int ptr = 0; + gfc_constructor_base ctor = expr->value.constructor; + gfc_array_size (expr, &array_size); for (i = 0; i < (int)mpz_get_ui (array_size); i++) { - ptr += gfc_target_encode_expr (gfc_get_array_element (expr, i), + ptr += gfc_target_encode_expr (gfc_constructor_lookup_expr (ctor, i), &buffer[ptr], buffer_size - ptr); } @@ -205,28 +209,29 @@ gfc_encode_character (int kind, int length, const gfc_char_t *string, static int encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size) { - gfc_constructor *ctr; + gfc_constructor *c; gfc_component *cmp; int ptr; tree type; type = gfc_typenode_for_spec (&source->ts); - ctr = source->value.constructor; - cmp = source->ts.u.derived->components; - for (;ctr; ctr = ctr->next, cmp = cmp->next) + for (c = gfc_constructor_first (source->value.constructor), + cmp = source->ts.u.derived->components; + c; + c = gfc_constructor_next (c), cmp = cmp->next) { gcc_assert (cmp); - if (!ctr->expr) + if (!c->expr) continue; ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl)) + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8; - if (ctr->expr->expr_type == EXPR_NULL) + if (c->expr->expr_type == EXPR_NULL) memset (&buffer[ptr], 0, int_size_in_bytes (TREE_TYPE (cmp->backend_decl))); else - gfc_target_encode_expr (ctr->expr, &buffer[ptr], + gfc_target_encode_expr (c->expr, &buffer[ptr], buffer_size - ptr); } @@ -302,10 +307,10 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer, static int interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result) { + gfc_constructor_base base = NULL; int array_size = 1; int i; int ptr = 0; - gfc_constructor *head = NULL, *tail = NULL; /* Calculate array size from its shape and rank. */ gcc_assert (result->rank > 0 && result->shape); @@ -316,27 +321,19 @@ interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result) /* Iterate over array elements, producing constructors. */ for (i = 0; i < array_size; i++) { - if (head == NULL) - head = tail = gfc_get_constructor (); - else - { - tail->next = gfc_get_constructor (); - tail = tail->next; - } + gfc_expr *e = gfc_get_constant_expr (result->ts.type, result->ts.kind, + &result->where); + e->ts = result->ts; - tail->where = result->where; - tail->expr = gfc_constant_result (result->ts.type, - result->ts.kind, &result->where); - tail->expr->ts = result->ts; + if (e->ts.type == BT_CHARACTER) + e->value.character.length = result->value.character.length; - if (tail->expr->ts.type == BT_CHARACTER) - tail->expr->value.character.length = result->value.character.length; + gfc_constructor_append_expr (&base, e, &result->where); - ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, - tail->expr); + ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e); } - result->value.constructor = head; + result->value.constructor = base; return ptr; } @@ -439,7 +436,6 @@ int gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result) { gfc_component *cmp; - gfc_constructor *head = NULL, *tail = NULL; int ptr; tree type; @@ -452,45 +448,37 @@ gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *resu /* Run through the derived type components. */ for (;cmp; cmp = cmp->next) { - if (head == NULL) - head = tail = gfc_get_constructor (); - else - { - tail->next = gfc_get_constructor (); - tail = tail->next; - } - - /* The constructor points to the component. */ - tail->n.component = cmp; - - tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind, - &result->where); - tail->expr->ts = cmp->ts; + gfc_constructor *c; + gfc_expr *e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind, + &result->where); + e->ts = cmp->ts; /* Copy shape, if needed. */ if (cmp->as && cmp->as->rank) { int n; - tail->expr->expr_type = EXPR_ARRAY; - tail->expr->rank = cmp->as->rank; + e->expr_type = EXPR_ARRAY; + e->rank = cmp->as->rank; - tail->expr->shape = gfc_get_shape (tail->expr->rank); - for (n = 0; n < tail->expr->rank; n++) + e->shape = gfc_get_shape (e->rank); + for (n = 0; n < e->rank; n++) { - mpz_init_set_ui (tail->expr->shape[n], 1); - mpz_add (tail->expr->shape[n], tail->expr->shape[n], + mpz_init_set_ui (e->shape[n], 1); + mpz_add (e->shape[n], e->shape[n], cmp->as->upper[n]->value.integer); - mpz_sub (tail->expr->shape[n], tail->expr->shape[n], + mpz_sub (e->shape[n], e->shape[n], cmp->as->lower[n]->value.integer); } } - ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl)); - gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, - tail->expr); + c = gfc_constructor_append_expr (&result->value.constructor, e, NULL); - result->value.constructor = head; + /* The constructor points to the component. */ + c->n.component = cmp; + + ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl)); + gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e); } return int_size_in_bytes (type); @@ -578,7 +566,7 @@ expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len) { int i; int ptr; - gfc_constructor *ctr; + gfc_constructor *c; gfc_component *cmp; unsigned char *buffer; @@ -589,16 +577,16 @@ expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len) declaration. */ if (e->ts.type == BT_DERIVED) { - ctr = e->value.constructor; - cmp = e->ts.u.derived->components; - for (;ctr; ctr = ctr->next, cmp = cmp->next) + for (c = gfc_constructor_first (e->value.constructor), + cmp = e->ts.u.derived->components; + c; c = gfc_constructor_next (c), cmp = cmp->next) { gcc_assert (cmp && cmp->backend_decl); - if (!ctr->expr) + if (!c->expr) continue; ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl)) + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8; - expr_to_char (ctr->expr, &data[ptr], &chk[ptr], len); + expr_to_char (c->expr, &data[ptr], &chk[ptr], len); } return len; } @@ -645,12 +633,13 @@ gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data, break; case EXPR_ARRAY: - for (c = e->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) { size_t elt_size = gfc_target_expr_size (c->expr); - if (c->n.offset) - len = elt_size * (size_t)mpz_get_si (c->n.offset); + if (c->offset) + len = elt_size * (size_t)mpz_get_si (c->offset); len = len + gfc_merge_initializers (ts, c->expr, &data[len], &chk[len], length - len); diff --git a/gcc/fortran/target-memory.h b/gcc/fortran/target-memory.h index 603362638dd..7cddc669983 100644 --- a/gcc/fortran/target-memory.h +++ b/gcc/fortran/target-memory.h @@ -22,8 +22,6 @@ along with GCC; see the file COPYING3. If not see #ifndef GFC_TARGET_MEMORY_H #define GFC_TARGET_MEMORY_H -#include "gfortran.h" - /* Convert a BOZ to REAL or COMPLEX. */ bool gfc_convert_boz (gfc_expr *, gfc_typespec *); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 75516cea554..7bce2ef866b 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -80,12 +80,10 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "gimple.h" -#include "ggc.h" -#include "toplev.h" -#include "real.h" +#include "diagnostic-core.h" /* For internal_error/fatal_error. */ #include "flags.h" #include "gfortran.h" +#include "constructor.h" #include "trans.h" #include "trans-stmt.h" #include "trans-types.h" @@ -93,8 +91,7 @@ along with GCC; see the file COPYING3. If not see #include "trans-const.h" #include "dependency.h" -static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *); -static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *); +static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base); /* The contents of this structure aren't actually used, just the address. */ static gfc_ss gfc_ss_terminator_var; @@ -149,7 +146,8 @@ gfc_conv_descriptor_data_get (tree desc) field = TYPE_FIELDS (type); gcc_assert (DATA_FIELD == 0); - t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE); + t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, + field, NULL_TREE); t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t); return t; @@ -174,7 +172,8 @@ gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value) field = TYPE_FIELDS (type); gcc_assert (DATA_FIELD == 0); - t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE); + t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, + field, NULL_TREE); gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value)); } @@ -193,7 +192,8 @@ gfc_conv_descriptor_data_addr (tree desc) field = TYPE_FIELDS (type); gcc_assert (DATA_FIELD == 0); - t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE); + t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, + field, NULL_TREE); return gfc_build_addr_expr (NULL_TREE, t); } @@ -209,8 +209,8 @@ gfc_conv_descriptor_offset (tree desc) field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD); gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); - return fold_build3 (COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); } tree @@ -240,8 +240,8 @@ gfc_conv_descriptor_dtype (tree desc) field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD); gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); - return fold_build3 (COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); } static tree @@ -259,8 +259,8 @@ gfc_conv_descriptor_dimension (tree desc, tree dim) && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE); - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); tmp = gfc_build_array_ref (tmp, dim, NULL); return tmp; } @@ -276,8 +276,8 @@ gfc_conv_descriptor_stride (tree desc, tree dim) field = gfc_advance_chain (field, STRIDE_SUBFIELD); gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), - tmp, field, NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + tmp, field, NULL_TREE); return tmp; } @@ -287,7 +287,9 @@ gfc_conv_descriptor_stride_get (tree desc, tree dim) tree type = TREE_TYPE (desc); gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); if (integer_zerop (dim) - && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) + && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE + ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT + ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) return gfc_index_one_node; return gfc_conv_descriptor_stride (desc, dim); @@ -312,8 +314,8 @@ gfc_conv_descriptor_lbound (tree desc, tree dim) field = gfc_advance_chain (field, LBOUND_SUBFIELD); gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), - tmp, field, NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + tmp, field, NULL_TREE); return tmp; } @@ -342,8 +344,8 @@ gfc_conv_descriptor_ubound (tree desc, tree dim) field = gfc_advance_chain (field, UBOUND_SUBFIELD); gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), - tmp, field, NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + tmp, field, NULL_TREE); return tmp; } @@ -382,6 +384,43 @@ gfc_build_null_descriptor (tree type) } +/* Modify a descriptor such that the lbound of a given dimension is the value + specified. This also updates ubound and offset accordingly. */ + +void +gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, + int dim, tree new_lbound) +{ + tree offs, ubound, lbound, stride; + tree diff, offs_diff; + + new_lbound = fold_convert (gfc_array_index_type, new_lbound); + + offs = gfc_conv_descriptor_offset_get (desc); + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]); + ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]); + stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]); + + /* Get difference (new - old) by which to shift stuff. */ + diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + new_lbound, lbound); + + /* Shift ubound and offset accordingly. This has to be done before + updating the lbound, as they depend on the lbound expression! */ + ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + ubound, diff); + gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound); + offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + diff, stride); + offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + offs, offs_diff); + gfc_conv_descriptor_offset_set (block, desc, offs); + + /* Finally set lbound to value we want. */ + gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound); +} + + /* Cleanup those #defines. */ #undef DATA_FIELD @@ -434,10 +473,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; @@ -522,9 +561,11 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, tree tmp; if (as && as->type == AS_EXPLICIT) - for (dim = 0; dim < se->loop->dimen; dim++) + for (n = 0; n < se->loop->dimen; n++) { - n = se->loop->order[dim]; + dim = se->ss->data.info.dim[n]; + gcc_assert (dim < as->rank); + gcc_assert (se->loop->dimen == as->rank); if (se->loop->to[n] == NULL_TREE) { /* Evaluate the lower bound. */ @@ -542,7 +583,8 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, upper = fold_convert (gfc_array_index_type, tmpse.expr); /* Set the upper bound of the loop to UPPER - LOWER. */ - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, upper, lower); tmp = gfc_evaluate_now (tmp, &se->pre); se->loop->to[n] = tmp; } @@ -588,8 +630,8 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post, if (onstack) { /* Make a temporary variable to hold the data. */ - tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem, - gfc_index_one_node); + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem), + nelem, gfc_index_one_node); tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)), @@ -640,8 +682,9 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post, tmp = gfc_build_memcpy_call (packed, source_data, size); gfc_add_expr_to_block (&do_copying, tmp); - was_packed = fold_build2 (EQ_EXPR, boolean_type_node, - packed, source_data); + was_packed = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, packed, + source_data); tmp = gfc_finish_block (&do_copying); tmp = build3_v (COND_EXPR, was_packed, tmp, build_empty_stmt (input_location)); @@ -669,6 +712,28 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post, } +/* Get the array reference dimension corresponding to the given loop dimension. + It is different from the true array dimension given by the dim array in + the case of a partial array reference + It is different from the loop dimension in the case of a transposed array. + */ + +static int +get_array_ref_dim (gfc_ss_info *info, int loop_dim) +{ + int n, array_dim, array_ref_dim; + + array_ref_dim = 0; + array_dim = info->dim[loop_dim]; + + for (n = 0; n < info->dimen; n++) + if (n != loop_dim && info->dim[n] < array_dim) + array_ref_dim++; + + return array_ref_dim; +} + + /* Generate code to create and initialize the descriptor for a temporary array. This is used for both temporaries needed by the scalarizer, and functions returning arrays. Adjusts the loop variables to be @@ -689,6 +754,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, tree eltype, tree initial, bool dynamic, bool dealloc, bool callee_alloc, locus * where) { + tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS]; tree type; tree desc; tree tmp; @@ -696,35 +762,50 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, tree nelem; tree cond; tree or_expr; - int n; - int dim; + int n, dim, tmp_dim; + + memset (from, 0, sizeof (from)); + memset (to, 0, sizeof (to)); gcc_assert (info->dimen > 0); + gcc_assert (loop->dimen == info->dimen); if (gfc_option.warn_array_temp && where) gfc_warning ("Creating array temporary at %L", where); /* Set the lower bound to zero. */ - for (dim = 0; dim < info->dimen; dim++) + for (n = 0; n < loop->dimen; n++) { - n = loop->order[dim]; + dim = info->dim[n]; + /* Callee allocated arrays may not have a known bound yet. */ if (loop->to[n]) - loop->to[n] = gfc_evaluate_now (fold_build2 (MINUS_EXPR, - gfc_array_index_type, - loop->to[n], loop->from[n]), pre); + loop->to[n] = gfc_evaluate_now ( + fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + loop->to[n], loop->from[n]), + pre); loop->from[n] = gfc_index_zero_node; + /* We are constructing the temporary's descriptor based on the loop + dimensions. As the dimensions may be accessed in arbitrary order + (think of transpose) the size taken from the n'th loop may not map + to the n'th dimension of the array. We need to reconstruct loop infos + in the right order before using it to set the descriptor + bounds. */ + tmp_dim = get_array_ref_dim (info, n); + from[tmp_dim] = loop->from[n]; + to[tmp_dim] = loop->to[n]; + info->delta[dim] = gfc_index_zero_node; info->start[dim] = gfc_index_zero_node; info->end[dim] = gfc_index_zero_node; info->stride[dim] = gfc_index_one_node; - info->dim[dim] = dim; } /* Initialize the descriptor. */ type = - gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1, + gfc_get_array_type_bounds (eltype, info->dimen, 0, from, to, 1, GFC_ARRAY_UNKNOWN, true); desc = gfc_create_var (type, "atmp"); GFC_DECL_PACKED_ARRAY (desc) = 1; @@ -751,25 +832,27 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, or_expr = NULL_TREE; - /* If there is at least one null loop->to[n], it is a callee allocated + /* If there is at least one null loop->to[n], it is a callee allocated array. */ - for (n = 0; n < info->dimen; n++) + for (n = 0; n < loop->dimen; n++) if (loop->to[n] == NULL_TREE) { size = NULL_TREE; break; } - for (n = 0; n < info->dimen; n++) - { + for (n = 0; n < loop->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_loc (input_location, + 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])); loop->to[n] = tmp; continue; } @@ -780,22 +863,25 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n], 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[n], + to[n]); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - loop->to[n], gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + to[n], gfc_index_one_node); /* Check whether the size for this dimension is negative. */ - cond = fold_build2 (LE_EXPR, boolean_type_node, tmp, - gfc_index_zero_node); + cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, tmp, + gfc_index_zero_node); cond = gfc_evaluate_now (cond, pre); if (n == 0) or_expr = cond; else - or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond); + or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, or_expr, cond); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, tmp); size = gfc_evaluate_now (size, pre); } @@ -805,11 +891,12 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, { /* If or_expr is true, then the extent in at least one dimension is zero and the size is set to zero. */ - size = fold_build3 (COND_EXPR, gfc_array_index_type, - or_expr, gfc_index_zero_node, size); + size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, + or_expr, gfc_index_zero_node, size); nelem = size; - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (gfc_get_element_type (type)))); } @@ -829,96 +916,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, } -/* Generate code to transpose array EXPR by creating a new descriptor - in which the dimension specifications have been reversed. */ - -void -gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr) -{ - tree dest, src, dest_index, src_index; - gfc_loopinfo *loop; - gfc_ss_info *dest_info; - gfc_ss *dest_ss, *src_ss; - gfc_se src_se; - int n; - - loop = se->loop; - - src_ss = gfc_walk_expr (expr); - dest_ss = se->ss; - - dest_info = &dest_ss->data.info; - gcc_assert (dest_info->dimen == 2); - - /* Get a descriptor for EXPR. */ - gfc_init_se (&src_se, NULL); - gfc_conv_expr_descriptor (&src_se, expr, src_ss); - gfc_add_block_to_block (&se->pre, &src_se.pre); - gfc_add_block_to_block (&se->post, &src_se.post); - src = src_se.expr; - - /* Allocate a new descriptor for the return value. */ - dest = gfc_create_var (TREE_TYPE (src), "atmp"); - dest_info->descriptor = dest; - se->expr = dest; - - /* Copy across the dtype field. */ - gfc_add_modify (&se->pre, - gfc_conv_descriptor_dtype (dest), - gfc_conv_descriptor_dtype (src)); - - /* Copy the dimension information, renumbering dimension 1 to 0 and - 0 to 1. */ - for (n = 0; n < 2; n++) - { - dest_info->delta[n] = gfc_index_zero_node; - dest_info->start[n] = gfc_index_zero_node; - dest_info->end[n] = gfc_index_zero_node; - dest_info->stride[n] = gfc_index_one_node; - dest_info->dim[n] = n; - - dest_index = gfc_rank_cst[n]; - src_index = gfc_rank_cst[1 - n]; - - gfc_conv_descriptor_stride_set (&se->pre, dest, dest_index, - gfc_conv_descriptor_stride_get (src, src_index)); - - gfc_conv_descriptor_lbound_set (&se->pre, dest, dest_index, - gfc_conv_descriptor_lbound_get (src, src_index)); - - gfc_conv_descriptor_ubound_set (&se->pre, dest, dest_index, - gfc_conv_descriptor_ubound_get (src, src_index)); - - if (!loop->to[n]) - { - gcc_assert (integer_zerop (loop->from[n])); - loop->to[n] = - fold_build2 (MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_ubound_get (dest, dest_index), - gfc_conv_descriptor_lbound_get (dest, dest_index)); - } - } - - /* Copy the data pointer. */ - dest_info->data = gfc_conv_descriptor_data_get (src); - gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data); - - /* Copy the offset. This is not changed by transposition; the top-left - element is still at the same offset as before, except where the loop - starts at zero. */ - if (!integer_zerop (loop->from[0])) - dest_info->offset = gfc_conv_descriptor_offset_get (src); - else - dest_info->offset = gfc_index_zero_node; - - gfc_conv_descriptor_offset_set (&se->pre, dest, - dest_info->offset); - - if (dest_info->dimen > loop->temp_dim) - loop->temp_dim = dest_info->dimen; -} - - /* Return the number of iterations in a loop that starts at START, ends at END, and has step STEP. */ @@ -929,10 +926,12 @@ gfc_get_iteration_count (tree start, tree end, tree step) tree type; type = TREE_TYPE (step); - tmp = fold_build2 (MINUS_EXPR, type, end, start); - tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step); - tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1)); - tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0)); + tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start); + tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, + build_int_cst (type, 1)); + tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp, + build_int_cst (type, 0)); return fold_convert (gfc_array_index_type, tmp); } @@ -953,7 +952,8 @@ gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra) ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]); /* Add EXTRA to the upper bound. */ - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + ubound, extra); gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp); /* Get the value of the current data pointer. */ @@ -961,11 +961,11 @@ gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra) /* Calculate the new array size. */ size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - ubound, gfc_index_one_node); - arg1 = fold_build2 (MULT_EXPR, size_type_node, - fold_convert (size_type_node, tmp), - fold_convert (size_type_node, size)); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + ubound, gfc_index_one_node); + arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + fold_convert (size_type_node, tmp), + fold_convert (size_type_node, size)); /* Call the realloc() function. */ tmp = gfc_call_realloc (pblock, arg0, arg1); @@ -1014,8 +1014,9 @@ gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr) of array constructor C. */ static bool -gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c) +gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base) { + gfc_constructor *c; gfc_iterator *i; mpz_t val; mpz_t len; @@ -1026,7 +1027,7 @@ gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c) mpz_init (val); dynamic = false; - for (; c; c = c->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { i = c->iterator; if (i && gfc_iterator_has_dynamic_bounds (i)) @@ -1095,7 +1096,8 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc))); esize = fold_convert (gfc_charlen_type_node, esize); - esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize, + esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + gfc_charlen_type_node, esize, build_int_cst (gfc_charlen_type_node, gfc_character_kinds[i].bit_size / 8)); @@ -1127,8 +1129,9 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, { /* Verify that all constructor elements are of the same length. */ - tree cond = fold_build2 (NE_EXPR, boolean_type_node, - first_len_val, se->string_length); + tree cond = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, first_len_val, + se->string_length); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, "Different CHARACTER lengths (%ld/%ld) in array constructor", @@ -1193,7 +1196,8 @@ gfc_trans_array_constructor_subarray (stmtblock_t * pblock, { tmp = gfc_get_iteration_count (loop.from[n], loop.to[n], gfc_index_one_node); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, tmp); } /* Grow the constructed array by SIZE elements. */ @@ -1210,8 +1214,8 @@ gfc_trans_array_constructor_subarray (stmtblock_t * pblock, gcc_assert (se.ss == gfc_ss_terminator); /* Increment the offset. */ - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - *poffset, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + *poffset, gfc_index_one_node); gfc_add_modify (&body, *poffset, tmp); /* Finish the loop. */ @@ -1231,7 +1235,7 @@ gfc_trans_array_constructor_subarray (stmtblock_t * pblock, static void gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, - tree desc, gfc_constructor * c, + tree desc, gfc_constructor_base base, tree * poffset, tree * offsetvar, bool dynamic) { @@ -1239,12 +1243,13 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, stmtblock_t body; gfc_se se; mpz_t size; + gfc_constructor *c; tree shadow_loopvar = NULL_TREE; gfc_saved_var saved_loopvar; mpz_init (size); - for (; c; c = c->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { /* If this is an iterator or an array, the offset must be a variable. */ if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset)) @@ -1289,7 +1294,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, n = 0; while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT)) { - p = p->next; + p = gfc_constructor_next (p); n++; } if (n < 4) @@ -1299,20 +1304,20 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, gfc_trans_array_ctor_element (&body, desc, *poffset, &se, c->expr); - *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type, - *poffset, gfc_index_one_node); + *poffset = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + *poffset, gfc_index_one_node); } else { /* Collect multiple scalar constants into a constructor. */ - tree list; + VEC(constructor_elt,gc) *v = NULL; tree init; tree bound; tree tmptype; HOST_WIDE_INT idx = 0; p = c; - list = NULL_TREE; /* Count the number of consecutive scalar constants. */ while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT)) @@ -1329,10 +1334,12 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, (gfc_get_pchar_type (p->expr->ts.kind), se.expr); - list = tree_cons (build_int_cst (gfc_array_index_type, - idx++), se.expr, list); + CONSTRUCTOR_APPEND_ELT (v, + build_int_cst (gfc_array_index_type, + idx++), + se.expr); c = p; - p = p->next; + p = gfc_constructor_next (p); } bound = build_int_cst (NULL_TREE, n - 1); @@ -1341,7 +1348,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, gfc_index_zero_node, bound); tmptype = build_array_type (type, tmptype); - init = build_constructor_from_list (tmptype, nreverse (list)); + init = build_constructor (tmptype, v); TREE_CONSTANT (init) = 1; TREE_STATIC (init) = 1; /* Create a static variable to hold the data. */ @@ -1367,8 +1374,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, tmp, init, bound); gfc_add_expr_to_block (&body, tmp); - *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type, - *poffset, + *poffset = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, *poffset, build_int_cst (gfc_array_index_type, n)); } if (!INTEGER_CST_P (*poffset)) @@ -1432,7 +1439,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind); /* Grow the array by TMP * TMP2 elements. */ - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, tmp2); gfc_grow_array (&implied_do_block, desc, tmp); } @@ -1443,13 +1451,14 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, /* Generate the exit condition. Depending on the sign of the step variable we have to generate the correct comparison. */ - tmp = fold_build2 (GT_EXPR, boolean_type_node, step, - build_int_cst (TREE_TYPE (step), 0)); - cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, - fold_build2 (GT_EXPR, boolean_type_node, - shadow_loopvar, end), - fold_build2 (LT_EXPR, boolean_type_node, - shadow_loopvar, end)); + tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + step, build_int_cst (TREE_TYPE (step), 0)); + cond = fold_build3_loc (input_location, COND_EXPR, + boolean_type_node, tmp, + fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, shadow_loopvar, end), + fold_build2_loc (input_location, LT_EXPR, + boolean_type_node, shadow_loopvar, end)); tmp = build1_v (GOTO_EXPR, exit_label); TREE_USED (exit_label) = 1; tmp = build3_v (COND_EXPR, cond, tmp, @@ -1460,7 +1469,9 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, gfc_add_expr_to_block (&body, loopbody); /* Increase loop variable by step. */ - tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (shadow_loopvar), shadow_loopvar, step); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + TREE_TYPE (shadow_loopvar), shadow_loopvar, + step); gfc_add_modify (&body, shadow_loopvar, tmp); /* Finish the loop. */ @@ -1585,13 +1596,14 @@ get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len) Returns TRUE if all elements are character constants. */ bool -get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len) +get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len) { + gfc_constructor *c; bool is_const; - + is_const = TRUE; - if (c == NULL) + if (gfc_constructor_first (base) == NULL) { if (len) *len = build_int_cstu (gfc_charlen_type_node, 0); @@ -1601,7 +1613,8 @@ get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len) /* Loop over all constructor elements to find out is_const, but in len we want to store the length of the first, not the last, element. We can of course exit the loop as soon as is_const is found to be false. */ - for (; c && is_const; c = c->next) + for (c = gfc_constructor_first (base); + c && is_const; c = gfc_constructor_next (c)) { switch (c->expr->expr_type) { @@ -1641,17 +1654,18 @@ get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len) return zero. Note, an empty or NULL array constructor returns zero. */ unsigned HOST_WIDE_INT -gfc_constant_array_constructor_p (gfc_constructor * c) +gfc_constant_array_constructor_p (gfc_constructor_base base) { unsigned HOST_WIDE_INT nelem = 0; + gfc_constructor *c = gfc_constructor_first (base); while (c) { if (c->iterator || c->expr->rank > 0 || c->expr->expr_type != EXPR_CONSTANT) return 0; - c = c->next; + c = gfc_constructor_next (c); nelem++; } return nelem; @@ -1665,18 +1679,18 @@ gfc_constant_array_constructor_p (gfc_constructor * c) tree gfc_build_constant_array_constructor (gfc_expr * expr, tree type) { - tree tmptype, list, init, tmp; + tree tmptype, init, tmp; HOST_WIDE_INT nelem; gfc_constructor *c; gfc_array_spec as; gfc_se se; int i; + VEC(constructor_elt,gc) *v = NULL; /* First traverse the constructor list, converting the constants to tree to build an initializer. */ nelem = 0; - list = NULL_TREE; - c = expr->value.constructor; + c = gfc_constructor_first (expr->value.constructor); while (c) { gfc_init_se (&se, NULL); @@ -1686,9 +1700,9 @@ gfc_build_constant_array_constructor (gfc_expr * expr, tree type) else if (POINTER_TYPE_P (type)) se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind), se.expr); - list = tree_cons (build_int_cst (gfc_array_index_type, nelem), - se.expr, list); - c = c->next; + CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem), + se.expr); + c = gfc_constructor_next (c); nelem++; } @@ -1702,20 +1716,22 @@ gfc_build_constant_array_constructor (gfc_expr * expr, tree type) as.type = AS_EXPLICIT; if (!expr->shape) { - as.lower[0] = gfc_int_expr (0); - as.upper[0] = gfc_int_expr (nelem - 1); + as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); + as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind, + NULL, nelem - 1); } else for (i = 0; i < expr->rank; i++) { int tmp = (int) mpz_get_si (expr->shape[i]); - as.lower[i] = gfc_int_expr (0); - as.upper[i] = gfc_int_expr (tmp - 1); + as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); + as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind, + NULL, tmp - 1); } tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true); - init = build_constructor_from_list (tmptype, nreverse (list)); + init = build_constructor (tmptype, v); TREE_CONSTANT (init) = 1; TREE_STATIC (init) = 1; @@ -1786,14 +1802,16 @@ constant_array_constructor_loop_size (gfc_loopinfo * loop) /* Only allow nonzero "from" in one-dimensional arrays. */ if (loop->dimen != 1) return NULL_TREE; - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - loop->to[i], loop->from[i]); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + loop->to[i], loop->from[i]); } else tmp = loop->to[i]; - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, tmp); } return size; @@ -1807,7 +1825,7 @@ constant_array_constructor_loop_size (gfc_loopinfo * loop) static void gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) { - gfc_constructor *c; + gfc_constructor_base c; tree offset; tree offsetvar; tree desc; @@ -1885,8 +1903,9 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) loop->from[n] = gfc_index_zero_node; loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n], gfc_index_integer_kind); - loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type, - loop->to[n], gfc_index_one_node); + loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + loop->to[n], gfc_index_one_node); } } @@ -1990,7 +2009,8 @@ gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info) gfc_init_se (&se, NULL); desc = info->subscript[dim]->data.info.descriptor; zero = gfc_rank_cst[0]; - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, gfc_conv_descriptor_ubound_get (desc, zero), gfc_conv_descriptor_lbound_get (desc, zero)); tmp = gfc_evaluate_now (tmp, &loop->pre); @@ -2046,9 +2066,10 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, break; case GFC_SS_REFERENCE: - /* Scalar reference. Evaluate this now. */ + /* Scalar argument to elemental procedure. Evaluate this + now. */ gfc_init_se (&se, NULL); - gfc_conv_expr_reference (&se, ss->expr); + gfc_conv_expr (&se, ss->expr); gfc_add_block_to_block (&loop->pre, &se.pre); gfc_add_block_to_block (&loop->post, &se.post); @@ -2168,9 +2189,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; } @@ -2316,10 +2340,6 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, && se->loop->ss->loop_chain->expr->symtree) name = se->loop->ss->loop_chain->expr->symtree->name; - if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain - && se->loop->ss->loop_chain->expr->symtree) - name = se->loop->ss->loop_chain->expr->symtree->name; - if (!name && se->loop && se->loop->ss && se->loop->ss->expr) { if (se->loop->ss->expr->expr_type == EXPR_FUNCTION @@ -2331,6 +2351,9 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, name = "unnamed constant"; } + if (TREE_CODE (descriptor) == VAR_DECL) + name = IDENTIFIER_POINTER (DECL_NAME (descriptor)); + /* If upper bound is present, include both bounds in the error message. */ if (check_upper) { @@ -2344,12 +2367,14 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, asprintf (&msg, "Index '%%ld' of dimension %d " "outside of expected range (%%ld:%%ld)", n+1); - fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo); + fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + index, tmp_lo); gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, fold_convert (long_integer_type_node, index), fold_convert (long_integer_type_node, tmp_lo), fold_convert (long_integer_type_node, tmp_up)); - fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp_up); + fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + index, tmp_up); gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, fold_convert (long_integer_type_node, index), fold_convert (long_integer_type_node, tmp_lo), @@ -2367,7 +2392,8 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, asprintf (&msg, "Index '%%ld' of dimension %d " "below lower bound of %%ld", n+1); - fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo); + fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + index, tmp_lo); gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, fold_convert (long_integer_type_node, index), fold_convert (long_integer_type_node, tmp_lo)); @@ -2379,7 +2405,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, @@ -2415,18 +2442,21 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, desc = info->subscript[dim]->data.info.descriptor; /* Get a zero-based index into the vector. */ - index = fold_build2 (MINUS_EXPR, gfc_array_index_type, - se->loop->loopvar[i], se->loop->from[i]); + index = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + se->loop->loopvar[i], se->loop->from[i]); /* Multiply the index by the stride. */ - index = fold_build2 (MULT_EXPR, gfc_array_index_type, - index, gfc_conv_array_stride (desc, 0)); + index = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + index, gfc_conv_array_stride (desc, 0)); /* Read the vector to get an index into info->descriptor. */ data = build_fold_indirect_ref_loc (input_location, gfc_conv_array_data (desc)); index = gfc_build_array_ref (data, index, NULL); index = gfc_evaluate_now (index, &se->pre); + index = fold_convert (gfc_array_index_type, index); /* Do any bounds checking on the final info->descriptor index. */ index = gfc_trans_array_bound_check (se, info->descriptor, @@ -2439,14 +2469,16 @@ 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])) - index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, - info->stride[i]); - if (!integer_zerop (info->delta[i])) - index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, - info->delta[i]); + if (!integer_onep (info->stride[dim])) + index = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, index, + info->stride[dim]); + if (!integer_zerop (info->delta[dim])) + index = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, index, + info->delta[dim]); break; default: @@ -2458,14 +2490,15 @@ 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])) - index = fold_build2 (PLUS_EXPR, gfc_array_index_type, - index, info->delta[i]); + if (!integer_zerop (info->delta[dim])) + index = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, index, info->delta[dim]); } /* Multiply by the stride. */ if (!integer_onep (stride)) - index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride); + index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + index, stride); return index; } @@ -2493,7 +2526,8 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) /* Add the offset for this dimension to the stored offset for all other dimensions. */ if (!integer_zerop (info->offset)) - index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset); + index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + index, info->offset); if (se->ss->expr && is_subref_array (se->ss->expr)) decl = se->ss->expr->symtree->n.sym->backend_decl; @@ -2531,6 +2565,9 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, gfc_se indexse; gfc_se tmpse; + if (ar->dimen == 0) + return; + /* Handle scalarized references separately. */ if (ar->type != AR_ELEMENT) { @@ -2569,8 +2606,8 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, tmp = tmpse.expr; } - cond = fold_build2 (LT_EXPR, boolean_type_node, - indexse.expr, tmp); + cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + indexse.expr, tmp); asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " "below lower bound of %%ld", n+1, sym->name); gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, @@ -2593,8 +2630,8 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, tmp = tmpse.expr; } - cond = fold_build2 (GT_EXPR, boolean_type_node, - indexse.expr, tmp); + cond = fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, indexse.expr, tmp); asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " "above upper bound of %%ld", n+1, sym->name); gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, @@ -2607,16 +2644,18 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, /* Multiply the index by the stride. */ stride = gfc_conv_array_stride (se->expr, n); - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr, - stride); + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + indexse.expr, stride); /* And add it to the total. */ - index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp); + index = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, index, tmp); } tmp = gfc_conv_array_offset (se->expr); if (!integer_zerop (tmp)) - index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp); + index = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, index, tmp); /* Access the calculated element. */ tmp = gfc_conv_array_data (se->expr); @@ -2677,20 +2716,22 @@ gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag, stride); gfc_add_block_to_block (pblock, &se.pre); - info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type, - info->offset, index); + info->offset = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + info->offset, index); info->offset = gfc_evaluate_now (info->offset, pblock); } - - i = loop->order[0]; - stride = gfc_conv_array_stride (info->descriptor, info->dim[i]); } - else - stride = gfc_conv_array_stride (info->descriptor, 0); + + i = loop->order[0]; + /* For the time being, the innermost loop is unconditionally on + the first dimension of the scalarization loop. */ + gcc_assert (i == 0); + stride = gfc_conv_array_stride (info->descriptor, info->dim[i]); /* Calculate the stride of the innermost loop. Hopefully this will - allow the backend optimizers to do their stuff more effectively. - */ + allow the backend optimizers to do their stuff more effectively. + */ info->stride0 = gfc_evaluate_now (stride, pblock); } else @@ -2716,8 +2757,9 @@ gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag, index = gfc_conv_array_index_offset (&se, info, info->dim[i], i, ar, stride); gfc_add_block_to_block (pblock, &se.pre); - info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type, - info->offset, index); + info->offset = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, info->offset, + index); info->offset = gfc_evaluate_now (info->offset, pblock); } @@ -2811,13 +2853,15 @@ gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, loop->from[n]); OMP_FOR_INIT (stmt) = init; /* The exit condition. */ - TREE_VEC_ELT (cond, 0) = build2 (LE_EXPR, boolean_type_node, - loop->loopvar[n], loop->to[n]); + TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR, + boolean_type_node, + loop->loopvar[n], loop->to[n]); + SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location); OMP_FOR_COND (stmt) = cond; /* Increment the loopvar. */ - tmp = build2 (PLUS_EXPR, gfc_array_index_type, - loop->loopvar[n], gfc_index_one_node); - TREE_VEC_ELT (incr, 0) = fold_build2 (MODIFY_EXPR, + tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + loop->loopvar[n], gfc_index_one_node); + TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, loop->loopvar[n], tmp); OMP_FOR_INCR (stmt) = incr; @@ -2826,8 +2870,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]); @@ -2838,8 +2892,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_loc (input_location, 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)); @@ -2849,8 +2903,11 @@ 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_loc (input_location, + 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. */ @@ -2952,54 +3009,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; @@ -3007,19 +3020,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; } @@ -3037,14 +3048,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 @@ -3055,24 +3066,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); } } @@ -3137,7 +3148,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: @@ -3212,11 +3223,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], - gfc_index_zero_node); + tmp = fold_build2_loc (input_location, 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); @@ -3224,32 +3234,36 @@ 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. */ - 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], - 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], - end); - stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - stride_neg, tmp); - non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, - stride_pos, stride_neg); + empty. */ + stride_pos = fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, info->stride[dim], + gfc_index_zero_node); + tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, + info->start[dim], end); + stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, stride_pos, tmp); + + stride_neg = fold_build2_loc (input_location, LT_EXPR, + boolean_type_node, + info->stride[dim], gfc_index_zero_node); + tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + info->start[dim], end); + stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, + stride_neg, tmp); + non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, + stride_pos, stride_neg); /* Check the start of the range against the lower and upper bounds of the array, if the range is not empty. @@ -3257,41 +3271,46 @@ 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 (TRUTH_AND_EXPR, boolean_type_node, - non_zerosized, tmp); - tmp2 = fold_build2 (GT_EXPR, boolean_type_node, - info->start[n], ubound); - tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - non_zerosized, tmp2); + tmp = fold_build2_loc (input_location, LT_EXPR, + boolean_type_node, + info->start[dim], lbound); + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, + non_zerosized, tmp); + tmp2 = fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, + info->start[dim], ubound); + tmp2 = fold_build2_loc (input_location, 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 (TRUTH_AND_EXPR, boolean_type_node, - non_zerosized, tmp); + tmp = fold_build2_loc (input_location, LT_EXPR, + boolean_type_node, + info->start[dim], lbound); + tmp = fold_build2_loc (input_location, 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); } @@ -3300,23 +3319,27 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) necessarily "end" (think 0:5:3, which doesn't contain 5) and check it against both lower and upper bounds. */ - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, - info->start[n]); - tmp = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp, - info->stride[n]); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, - tmp); - tmp2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, lbound); - tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - non_zerosized, tmp2); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, end, + info->start[dim]); + tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, + gfc_array_index_type, tmp, + info->stride[dim]); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, end, tmp); + tmp2 = fold_build2_loc (input_location, LT_EXPR, + boolean_type_node, tmp, lbound); + tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, non_zerosized, tmp2); if (check_upper) { - tmp3 = fold_build2 (GT_EXPR, boolean_type_node, tmp, ubound); - tmp3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - non_zerosized, tmp3); + tmp3 = fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, tmp, ubound); + tmp3 = fold_build2_loc (input_location, 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), @@ -3332,36 +3355,43 @@ 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]); - tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp, - info->stride[n]); - 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)); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, end, + info->start[dim]); + tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, + gfc_array_index_type, tmp, + info->stride[dim]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + gfc_index_one_node, tmp); + tmp = fold_build2_loc (input_location, 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, "%s, size mismatch for dimension %d " - "of array '%s' (%%ld/%%ld)", gfc_msg_bounds, - info->dim[n]+1, ss->expr->symtree->name); + tmp3 = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, tmp, size[n]); + asprintf (&msg, "Array bound mismatch for dimension %d " + "of array '%s' (%%ld/%%ld)", + dim + 1, ss->expr->symtree->name); + gfc_trans_runtime_check (true, false, tmp3, &inner, &ss->expr->where, msg, fold_convert (long_integer_type_node, tmp), fold_convert (long_integer_type_node, size[n])); + gfc_free (msg); } else @@ -3456,6 +3486,7 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, gfc_ref *lref; gfc_ref *rref; int nDepend = 0; + int i, j; loop->temp_ss = NULL; @@ -3478,9 +3509,21 @@ 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; + + for (i = 0; i < dest->data.info.dimen; i++) + for (j = 0; j < ss->data.info.dimen; j++) + if (i != j + && dest->data.info.dim[i] == ss->data.info.dim[j]) + { + /* If we don't access array elements in the same order, + there is a dependency. */ + nDepend = 1; + goto temporary; + } #if 0 /* TODO : loop shifting. */ if (nDepend == 1) @@ -3519,6 +3562,8 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, } } +temporary: + if (nDepend == 1) { tree base_type = gfc_typenode_for_spec (&dest->expr->ts); @@ -3547,14 +3592,13 @@ 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; tree tmp; gfc_ss *loopspec[GFC_MAX_DIMENSIONS]; bool dynamic[GFC_MAX_DIMENSIONS]; - gfc_constructor *c; mpz_t *cshape; mpz_t i; @@ -3564,14 +3608,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; @@ -3579,6 +3643,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) if (ss->type == GFC_SS_CONSTRUCTOR) { + gfc_constructor_base base; /* An unknown size constructor will always be rank one. Higher rank constructors will either have known shape, or still be wrapped in a call to reshape. */ @@ -3588,8 +3653,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) can be determined at compile time. Prefer not to otherwise, since the general case involves realloc, and it's better to avoid that overhead if possible. */ - c = ss->expr->value.constructor; - dynamic[n] = gfc_get_array_constructor_size (&i, c); + base = ss->expr->value.constructor; + dynamic[n] = gfc_get_array_constructor_size (&i, base); if (!dynamic[n] || !loopspec[n]) loopspec[n] = ss; continue; @@ -3597,22 +3662,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 @@ -3623,14 +3682,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]) @@ -3643,26 +3702,29 @@ 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]; - mpz_set (i, cshape[n]); + loop->from[n] = info->start[dim]; + mpz_set (i, cshape[get_array_ref_dim (info, 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])) - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - tmp, info->stride[n]); - loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type, - loop->from[n], tmp); + if (!integer_onep (info->stride[dim])) + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, + info->stride[dim]); + loop->to[n] = fold_build2_loc (input_location, 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: @@ -3674,17 +3736,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 (); @@ -3692,22 +3750,23 @@ 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 (MAX_EXPR, gfc_array_index_type, tmp, - build_int_cst (gfc_array_index_type, -1)); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, loop->to[n], + loop->from[n]); + tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, + gfc_array_index_type, tmp, info->stride[dim]); + tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, + tmp, build_int_cst (gfc_array_index_type, -1)); loop->to[n] = gfc_evaluate_now (tmp, &loop->pre); /* Make the loop variable start at 0. */ loop->from[n] = gfc_index_zero_node; @@ -3736,6 +3795,11 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info)); loop->temp_ss->type = GFC_SS_SECTION; loop->temp_ss->data.info.dimen = n; + + gcc_assert (loop->temp_ss->data.info.dimen != 0); + for (n = 0; n < loop->temp_ss->data.info.dimen; n++) + loop->temp_ss->data.info.dim[n] = n; + gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &loop->temp_ss->data.info, tmp, NULL_TREE, false, true, false, where); @@ -3766,24 +3830,89 @@ 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])) - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - tmp, info->stride[n]); + if (!integer_onep (info->stride[dim])) + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + tmp, info->stride[dim]); /* Then subtract this from our starting value. */ - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - info->start[n], tmp); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + info->start[dim], tmp); - info->delta[n] = gfc_evaluate_now (tmp, &loop->pre); + info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre); } } } } +/* Calculate the size of a given array dimension from the bounds. This + is simply (ubound - lbound + 1) if this expression is positive + or 0 if it is negative (pick either one if it is zero). Optionally + (if or_expr is present) OR the (expression != 0) condition to it. */ + +tree +gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr) +{ + tree res; + tree cond; + + /* Calculate (ubound - lbound + 1). */ + res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + ubound, lbound); + res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res, + gfc_index_one_node); + + /* Check whether the size for this dimension is negative. */ + cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res, + gfc_index_zero_node); + res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, + gfc_index_zero_node, res); + + /* Build OR expression. */ + if (or_expr) + *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, *or_expr, cond); + + return res; +} + + +/* For an array descriptor, get the total number of elements. This is just + the product of the extents along all dimensions. */ + +tree +gfc_conv_descriptor_size (tree desc, int rank) +{ + tree res; + int dim; + + res = gfc_index_one_node; + + for (dim = 0; dim < rank; ++dim) + { + tree lbound; + tree ubound; + tree extent; + + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]); + ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]); + + extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); + res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + res, extent); + } + + return res; +} + + /* Fills in an array descriptor, and returns the size of the array. The size will be a simple_val, ie a variable or a constant. Also calculates the offset of the base. Returns the size of the array. @@ -3792,20 +3921,20 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) offset = 0; for (n = 0; n < rank; n++) { - a.lbound[n] = specified_lower_bound; - offset = offset + a.lbond[n] * stride; - size = 1 - lbound; - a.ubound[n] = specified_upper_bound; - a.stride[n] = stride; - size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound - stride = stride * size; + a.lbound[n] = specified_lower_bound; + offset = offset + a.lbond[n] * stride; + size = 1 - lbound; + a.ubound[n] = specified_upper_bound; + a.stride[n] = stride; + size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound + stride = stride * size; } return (stride); } */ /*GCC ARRAYS*/ static tree -gfc_array_init_size (tree descriptor, int rank, tree * poffset, +gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock) { @@ -3814,7 +3943,6 @@ gfc_array_init_size (tree descriptor, int rank, tree * poffset, tree size; tree offset; tree stride; - tree cond; tree or_expr; tree thencase; tree elsecase; @@ -3834,14 +3962,17 @@ gfc_array_init_size (tree descriptor, int rank, tree * poffset, tmp = gfc_conv_descriptor_dtype (descriptor); gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor))); - or_expr = NULL_TREE; + or_expr = boolean_false_node; for (n = 0; n < rank; n++) { + tree conv_lbound; + tree conv_ubound; + /* We have 3 possibilities for determining the size of the array: - lower == NULL => lbound = 1, ubound = upper[n] - upper[n] = NULL => lbound = 1, ubound = lower[n] - upper[n] != NULL => lbound = lower[n], ubound = upper[n] */ + lower == NULL => lbound = 1, ubound = upper[n] + upper[n] = NULL => lbound = 1, ubound = lower[n] + upper[n] != NULL => lbound = lower[n], ubound = upper[n] */ ubound = upper[n]; /* Set lower bound. */ @@ -3851,27 +3982,26 @@ gfc_array_init_size (tree descriptor, int rank, tree * poffset, else { gcc_assert (lower[n]); - if (ubound) - { + if (ubound) + { gfc_conv_expr_type (&se, lower[n], gfc_array_index_type); gfc_add_block_to_block (pblock, &se.pre); - } - else - { - se.expr = gfc_index_one_node; - ubound = lower[n]; - } + } + else + { + se.expr = gfc_index_one_node; + ubound = lower[n]; + } } gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n], se.expr); + conv_lbound = se.expr; /* Work out the offset for this component. */ - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride); - offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp); - - /* Start the calculation for the size of this dimension. */ - size = fold_build2 (MINUS_EXPR, gfc_array_index_type, - gfc_index_one_node, se.expr); + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + se.expr, stride); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, offset, tmp); /* Set upper bound. */ gfc_init_se (&se, NULL); @@ -3879,35 +4009,66 @@ gfc_array_init_size (tree descriptor, int rank, tree * poffset, gfc_conv_expr_type (&se, ubound, gfc_array_index_type); gfc_add_block_to_block (pblock, &se.pre); - gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr); + gfc_conv_descriptor_ubound_set (pblock, descriptor, + gfc_rank_cst[n], se.expr); + conv_ubound = se.expr; /* Store the stride. */ - gfc_conv_descriptor_stride_set (pblock, descriptor, gfc_rank_cst[n], stride); - - /* Calculate the size of this dimension. */ - size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size); - - /* Check whether the size for this dimension is negative. */ - cond = fold_build2 (LE_EXPR, boolean_type_node, size, - gfc_index_zero_node); - if (n == 0) - or_expr = cond; - else - or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond); + gfc_conv_descriptor_stride_set (pblock, descriptor, + gfc_rank_cst[n], stride); - size = fold_build3 (COND_EXPR, gfc_array_index_type, cond, - gfc_index_zero_node, size); + /* Calculate size and check whether extent is negative. */ + size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr); /* Multiply the stride by the number of elements in this dimension. */ - stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size); + stride = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, stride, size); stride = gfc_evaluate_now (stride, pblock); } + for (n = rank; n < rank + corank; n++) + { + ubound = upper[n]; + + /* Set lower bound. */ + gfc_init_se (&se, NULL); + if (lower == NULL || lower[n] == NULL) + { + gcc_assert (n == rank + corank - 1); + se.expr = gfc_index_one_node; + } + else + { + if (ubound || n == rank + corank - 1) + { + gfc_conv_expr_type (&se, lower[n], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + } + else + { + se.expr = gfc_index_one_node; + ubound = lower[n]; + } + } + gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n], + se.expr); + + if (n < rank + corank - 1) + { + gfc_init_se (&se, NULL); + gcc_assert (ubound); + gfc_conv_expr_type (&se, ubound, gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_conv_descriptor_ubound_set (pblock, descriptor, + gfc_rank_cst[n], se.expr); + } + } + /* The stride is the number of elements in the array, so multiply by the size of an element to get the total size. */ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, - fold_convert (gfc_array_index_type, tmp)); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + stride, fold_convert (gfc_array_index_type, tmp)); if (poffset != NULL) { @@ -3951,14 +4112,15 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) gfc_expr **lower; gfc_expr **upper; gfc_ref *ref, *prev_ref = NULL; - bool allocatable_array; + bool allocatable_array, coarray; ref = expr->ref; /* Find the last reference in the chain. */ while (ref && ref->next != NULL) { - gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT); + gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT + || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0)); prev_ref = ref; ref = ref->next; } @@ -3967,16 +4129,39 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) return false; if (!prev_ref) - allocatable_array = expr->symtree->n.sym->attr.allocatable; + { + allocatable_array = expr->symtree->n.sym->attr.allocatable; + coarray = expr->symtree->n.sym->attr.codimension; + } else - allocatable_array = prev_ref->u.c.component->attr.allocatable; + { + allocatable_array = prev_ref->u.c.component->attr.allocatable; + coarray = prev_ref->u.c.component->attr.codimension; + } + + /* Return if this is a scalar coarray. */ + if ((!prev_ref && !expr->symtree->n.sym->attr.dimension) + || (prev_ref && !prev_ref->u.c.component->attr.dimension)) + { + gcc_assert (coarray); + return false; + } /* Figure out the size of the array. */ switch (ref->u.ar.type) { case AR_ELEMENT: - lower = NULL; - upper = ref->u.ar.start; + if (!coarray) + { + lower = NULL; + upper = ref->u.ar.start; + break; + } + /* Fall through. */ + + case AR_SECTION: + lower = ref->u.ar.start; + upper = ref->u.ar.end; break; case AR_FULL: @@ -3986,18 +4171,14 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) upper = ref->u.ar.as->upper; break; - case AR_SECTION: - lower = ref->u.ar.start; - upper = ref->u.ar.end; - break; - default: gcc_unreachable (); break; } - size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset, - lower, upper, &se->pre); + size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, + ref->u.ar.as->corank, &offset, lower, upper, + &se->pre); /* Allocate memory to store the data. */ pointer = gfc_conv_descriptor_data_get (se->expr); @@ -4008,7 +4189,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr); else tmp = gfc_allocate_with_status (&se->pre, size, pstat); - tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, pointer, + tmp); gfc_add_expr_to_block (&se->pre, tmp); gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset); @@ -4046,8 +4228,8 @@ gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr) gfc_add_expr_to_block (&block, tmp); /* Zero the data pointer. */ - tmp = fold_build2 (MODIFY_EXPR, void_type_node, - var, build_int_cst (TREE_TYPE (var), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + var, build_int_cst (TREE_TYPE (var), 0)); gfc_add_expr_to_block (&block, tmp); return gfc_finish_block (&block); @@ -4062,11 +4244,10 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) { gfc_constructor *c; tree tmp; - mpz_t maxval; gfc_se se; HOST_WIDE_INT hi; unsigned HOST_WIDE_INT lo; - tree index, range; + tree index; VEC(constructor_elt,gc) *v = NULL; switch (expr->expr_type) @@ -4101,7 +4282,8 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) case EXPR_ARRAY: /* Create a vector of all the elements. */ - for (c = expr->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) { if (c->iterator) { @@ -4114,46 +4296,17 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) gfc_option.flag_max_array_constructor); return NULL_TREE; } - if (mpz_cmp_si (c->n.offset, 0) != 0) - index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind); + if (mpz_cmp_si (c->offset, 0) != 0) + index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind); else index = NULL_TREE; - mpz_init (maxval); - if (mpz_cmp_si (c->repeat, 0) != 0) - { - tree tmp1, tmp2; - - mpz_set (maxval, c->repeat); - mpz_add (maxval, c->n.offset, maxval); - mpz_sub_ui (maxval, maxval, 1); - tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); - if (mpz_cmp_si (c->n.offset, 0) != 0) - { - mpz_add_ui (maxval, c->n.offset, 1); - tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); - } - else - tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind); - - range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2); - } - else - range = NULL; - mpz_clear (maxval); gfc_init_se (&se, NULL); switch (c->expr->expr_type) { case EXPR_CONSTANT: gfc_conv_constant (&se, c->expr); - if (range == NULL_TREE) - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); - else - { - if (index != NULL_TREE) - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); - CONSTRUCTOR_APPEND_ELT (v, range, se.expr); - } + CONSTRUCTOR_APPEND_ELT (v, index, se.expr); break; case EXPR_STRUCTURE: @@ -4167,14 +4320,7 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) for one reason or another, assuming that if they are standard defying the frontend will catch them. */ gfc_conv_expr (&se, c->expr); - if (range == NULL_TREE) - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); - else - { - if (index != NULL_TREE) - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); - CONSTRUCTOR_APPEND_ELT (v, range, se.expr); - } + CONSTRUCTOR_APPEND_ELT (v, index, se.expr); break; } } @@ -4236,8 +4382,10 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, gfc_add_modify (pblock, ubound, se.expr); } /* The offset of this dimension. offset = offset - lbound * stride. */ - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size); - offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp); + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + lbound, size); + offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + offset, tmp); /* The size of this dimension, and the stride of the next. */ if (dim + 1 < as->rank) @@ -4248,10 +4396,13 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride))) { /* 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, ubound, tmp); - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_index_one_node, lbound); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, ubound, tmp); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, tmp); if (stride) gfc_add_modify (pblock, stride, tmp); else @@ -4259,10 +4410,11 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, /* Make sure that negative size arrays are translated to being zero size. */ - tmp = fold_build2 (GE_EXPR, boolean_type_node, - stride, gfc_index_zero_node); - tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp, - stride, gfc_index_zero_node); + tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + stride, gfc_index_zero_node); + tmp = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, tmp, + stride, gfc_index_zero_node); gfc_add_modify (pblock, stride, tmp); } @@ -4278,10 +4430,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; @@ -4292,32 +4445,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); + tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl); + 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); @@ -4328,51 +4481,48 @@ 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 size of an element to get the total size. */ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, - fold_convert (gfc_array_index_type, tmp)); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, 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; @@ -4380,7 +4530,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); @@ -4390,31 +4540,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) @@ -4423,10 +4571,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); } @@ -4441,22 +4586,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; @@ -4469,10 +4614,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); @@ -4481,35 +4629,33 @@ 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); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp, + gfc_index_one_node); + 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. */ @@ -4517,14 +4663,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); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + stride, gfc_index_zero_node); + tmp = fold_build3_loc (input_location, 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; @@ -4554,12 +4700,12 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) { /* Don't repack unknown shape arrays when the first stride is 1. */ - tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed), - partial, stmt_packed, stmt_unpacked); + tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed), + partial, stmt_packed, stmt_unpacked); } 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; @@ -4574,49 +4720,62 @@ 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) { /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */ char * msg; + tree temp; + + temp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, ubound, lbound); + temp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + gfc_index_one_node, temp); + stride2 = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, dubound, + dlbound); + stride2 = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + gfc_index_one_node, stride2); + tmp = fold_build2_loc (input_location, 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); + + gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg, + fold_convert (long_integer_type_node, temp), + fold_convert (long_integer_type_node, stride2)); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - ubound, lbound); - stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, - dubound, dlbound); - tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2); - asprintf (&msg, "%s for dimension %d of array '%s'", - gfc_msg_bounds, n+1, sym->name); - gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg); gfc_free (msg); } } @@ -4624,52 +4783,55 @@ 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, - dubound, dlbound); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound); - gfc_add_modify (&block, ubound, tmp); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, dubound, dlbound); + tmp = fold_build2_loc (input_location, 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); - offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp); + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + lbound, stride); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, offset, tmp); /* 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, - gfc_index_one_node, lbound); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - ubound, tmp); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, - size, tmp); - stmt_packed = size; - } - - /* 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); - } - } + /* 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_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_index_one_node, lbound); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, ubound, tmp); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, tmp); + stmt_packed = size; + } + + /* Assign the stride. */ + if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) + tmp = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, partial, + stmt_unpacked, stmt_packed); + else + tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked; + gfc_add_modify (&init, stride, tmp); + } + } else { stride = GFC_TYPE_ARRAY_SIZE (type); @@ -4677,26 +4839,27 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) if (stride && !INTEGER_CST_P (stride)) { /* Calculate size = stride * (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, - ubound, tmp); - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - GFC_TYPE_ARRAY_STRIDE (type, n), tmp); - gfc_add_modify (&block, stride, tmp); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_index_one_node, lbound); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + ubound, tmp); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + GFC_TYPE_ARRAY_STRIDE (type, n), 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_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - gfc_trans_vla_type_sizes (sym, &block); + gfc_trans_vla_type_sizes (sym, &init); - stmt = gfc_finish_block (&block); - - 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); @@ -4706,18 +4869,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. */ @@ -4730,26 +4893,27 @@ 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)); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp, tmpdesc); + 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); } @@ -4802,8 +4966,9 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset, case REF_COMPONENT: field = ref->u.c.component->backend_decl; gcc_assert (field && TREE_CODE (field) == FIELD_DECL); - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), - tmp, field, NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), + tmp, field, NULL_TREE); break; case REF_SUBSTRING: @@ -4833,18 +4998,25 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset, gfc_init_se (&start, NULL); gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type); jtmp = gfc_evaluate_now (start.expr, block); - itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp); - itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride); - index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index); + itmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, itmp, jtmp); + itmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, itmp, stride); + index = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, itmp, index); index = gfc_evaluate_now (index, block); /* Update the stride. */ gfc_init_se (&start, NULL); gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type); - itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp); - itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - gfc_index_one_node, itmp); - stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp); + itmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, start.expr, + jtmp); + itmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + gfc_index_one_node, itmp); + stride = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, stride, itmp); stride = gfc_evaluate_now (stride, block); } @@ -4908,7 +5080,8 @@ get_array_charlen (gfc_expr *expr, gfc_se *se) /* Add the string lengths and assign them to the expression string length backend declaration. */ gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, - fold_build2 (PLUS_EXPR, gfc_charlen_type_node, + fold_build2_loc (input_location, PLUS_EXPR, + gfc_charlen_type_node, expr->value.op.op1->ts.u.cl->backend_decl, expr->value.op.op2->ts.u.cl->backend_decl)); } @@ -4949,8 +5122,9 @@ get_array_charlen (gfc_expr *expr, gfc_se *se) gfc_add_block_to_block (&se->pre, &tse.pre); gfc_add_block_to_block (&se->post, &tse.post); tse.expr = fold_convert (gfc_charlen_type_node, tse.expr); - tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr, - build_int_cst (gfc_charlen_type_node, 0)); + tse.expr = fold_build2_loc (input_location, MAX_EXPR, + gfc_charlen_type_node, tse.expr, + build_int_cst (gfc_charlen_type_node, 0)); expr->ts.u.cl->backend_decl = tse.expr; gfc_free_interface_mapping (&mapping); break; @@ -5043,7 +5217,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) if (full) { - if (se->direct_byref) + if (se->direct_byref && !se->byref_noassign) { /* Copy the descriptor for pointer assignments. */ gfc_add_modify (&se->pre, se->expr, desc); @@ -5221,8 +5395,6 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) gfc_trans_scalarizing_loops (&loop, &block); desc = loop.temp_ss->data.info.descriptor; - - gcc_assert (is_gimple_lvalue (desc)); } else if (expr->expr_type == EXPR_FUNCTION) { @@ -5250,7 +5422,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) desc = info->descriptor; gcc_assert (secss && secss != gfc_ss_terminator); - if (se->direct_byref) + if (se->direct_byref && !se->byref_noassign) { /* For pointer assignments we fill in the destination. */ parm = se->expr; @@ -5260,7 +5432,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) { /* Otherwise make a new one. */ parmtype = gfc_get_element_type (TREE_TYPE (desc)); - parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, + parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0, loop.from, loop.to, 0, GFC_ARRAY_UNKNOWN, false); parm = gfc_create_var (parmtype, "parm"); @@ -5311,15 +5483,17 @@ 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); } tmp = gfc_conv_array_lbound (desc, n); - tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp); - - tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride); - offset = fold_build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp); + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), + start, tmp); + tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), + tmp, stride); + offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), + offset, tmp); if (info->ref && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT) @@ -5343,9 +5517,11 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) || info->ref->u.ar.type != AR_FULL) && !integer_onep (from)) { - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - gfc_index_one_node, from); - to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, gfc_index_one_node, + from); + to = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, to, tmp); from = gfc_index_one_node; } gfc_conv_descriptor_lbound_set (&loop.pre, parm, @@ -5357,25 +5533,27 @@ 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 = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + 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); + base = fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE (base), base, stride); } else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) { tmp = gfc_conv_array_lbound (desc, n); - tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base), - tmp, loop.from[dim]); - tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base), - tmp, gfc_conv_array_stride (desc, n)); - base = fold_build2 (PLUS_EXPR, TREE_TYPE (base), - tmp, base); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE (base), tmp, loop.from[dim]); + tmp = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (base), tmp, + gfc_conv_array_stride (desc, n)); + base = fold_build2_loc (input_location, PLUS_EXPR, + TREE_TYPE (base), tmp, base); } /* Store the new stride. */ @@ -5408,7 +5586,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) desc = parm; } - if (!se->direct_byref) + if (!se->direct_byref || se->byref_noassign) { /* Get a pointer to the new descriptor. */ if (se->want_pointer) @@ -5442,15 +5620,16 @@ array_parameter_size (tree desc, gfc_expr *expr, tree *size) tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node); tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node); - *size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound); - *size = fold_build2 (PLUS_EXPR, gfc_array_index_type, *size, - gfc_index_one_node); - *size = fold_build2 (MAX_EXPR, gfc_array_index_type, *size, - gfc_index_zero_node); + *size = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, ubound, lbound); + *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + *size, gfc_index_one_node); + *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, + *size, gfc_index_zero_node); } elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); - *size = fold_build2 (MULT_EXPR, gfc_array_index_type, *size, - fold_convert (gfc_array_index_type, elem)); + *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + *size, fold_convert (gfc_array_index_type, elem)); } /* Convert an array for passing as an actual parameter. */ @@ -5480,6 +5659,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, ultimate_ptr_comp = false; ultimate_alloc_comp = false; + for (ref = expr->ref; ref; ref = ref->next) { if (ref->next == NULL) @@ -5566,7 +5746,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, contiguous = g77 && !this_array_result && contiguous; /* There is no need to pack and unpack the array, if it is contiguous - and not deferred or assumed shape. */ + and not a deferred- or assumed-shape array, or if it is simply + contiguous. */ no_pack = ((sym && sym->as && !sym->attr.pointer && sym->as->type != AS_DEFERRED @@ -5574,7 +5755,9 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, || (ref && ref->u.ar.as && ref->u.ar.as->type != AS_DEFERRED - && ref->u.ar.as->type != AS_ASSUMED_SHAPE)); + && ref->u.ar.as->type != AS_ASSUMED_SHAPE) + || + gfc_is_simply_contiguous (expr, false)); no_pack = contiguous && no_pack; @@ -5638,9 +5821,25 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, gfc_add_expr_to_block (&se->post, tmp); } - if (g77) + if (g77 || (fsym && fsym->attr.contiguous + && !gfc_is_simply_contiguous (expr, false))) { + tree origptr = NULL_TREE; + desc = se->expr; + + /* For contiguous arrays, save the original value of the descriptor. */ + if (!g77) + { + origptr = gfc_create_var (pvoid_type_node, "origptr"); + tmp = build_fold_indirect_ref_loc (input_location, desc); + tmp = gfc_conv_array_data (tmp); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (origptr), origptr, + fold_convert (TREE_TYPE (origptr), tmp)); + gfc_add_expr_to_block (&se->pre, tmp); + } + /* Repack the array. */ if (gfc_option.warn_array_temp) { @@ -5657,14 +5856,22 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, if (fsym && fsym->attr.optional && sym && sym->attr.optional) { tmp = gfc_conv_expr_present (sym); - ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp, - fold_convert (TREE_TYPE (se->expr), ptr), + ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr), + tmp, fold_convert (TREE_TYPE (se->expr), ptr), fold_convert (TREE_TYPE (se->expr), null_pointer_node)); } ptr = gfc_evaluate_now (ptr, &se->pre); - se->expr = ptr; + /* Use the packed data for the actual argument, except for contiguous arrays, + where the descriptor's data component is set. */ + if (g77) + se->expr = ptr; + else + { + tmp = build_fold_indirect_ref_loc (input_location, desc); + gfc_conv_descriptor_data_set (&se->pre, tmp, ptr); + } if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS) { @@ -5679,12 +5886,13 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, tmp = build_fold_indirect_ref_loc (input_location, desc); tmp = gfc_conv_array_data (tmp); - tmp = fold_build2 (NE_EXPR, boolean_type_node, - fold_convert (TREE_TYPE (tmp), ptr), tmp); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + fold_convert (TREE_TYPE (tmp), ptr), tmp); if (fsym && fsym->attr.optional && sym && sym->attr.optional) - tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - gfc_conv_expr_present (sym), tmp); + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, + gfc_conv_expr_present (sym), tmp); gfc_trans_runtime_check (false, true, tmp, &se->pre, &expr->where, msg); @@ -5713,12 +5921,13 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, tmp = build_fold_indirect_ref_loc (input_location, desc); tmp = gfc_conv_array_data (tmp); - tmp = fold_build2 (NE_EXPR, boolean_type_node, - fold_convert (TREE_TYPE (tmp), ptr), tmp); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + fold_convert (TREE_TYPE (tmp), ptr), tmp); if (fsym && fsym->attr.optional && sym && sym->attr.optional) - tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - gfc_conv_expr_present (sym), tmp); + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, + gfc_conv_expr_present (sym), tmp); tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); @@ -5726,6 +5935,14 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, gfc_add_block_to_block (&block, &se->post); gfc_init_block (&se->post); + + /* Reset the descriptor pointer. */ + if (!g77) + { + tmp = build_fold_indirect_ref_loc (input_location, desc); + gfc_conv_descriptor_data_set (&se->post, tmp, origptr); + } + gfc_add_block_to_block (&se->post, &block); } } @@ -5752,8 +5969,8 @@ gfc_trans_dealloc_allocated (tree descriptor) gfc_add_expr_to_block (&block, tmp); /* Zero the data pointer. */ - tmp = fold_build2 (MODIFY_EXPR, void_type_node, - var, build_int_cst (TREE_TYPE (var), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + var, build_int_cst (TREE_TYPE (var), 0)); gfc_add_expr_to_block (&block, tmp); return gfc_finish_block (&block); @@ -5771,13 +5988,15 @@ get_full_array_size (stmtblock_t *block, tree decl, int rank) idx = gfc_rank_cst[rank - 1]; nelems = gfc_conv_descriptor_ubound_get (decl, idx); tmp = gfc_conv_descriptor_lbound_get (decl, idx); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node); + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + nelems, tmp); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); tmp = gfc_evaluate_now (tmp, block); nelems = gfc_conv_descriptor_stride_get (decl, idx); - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp); + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + nelems, tmp); return gfc_evaluate_now (tmp, block); } @@ -5786,8 +6005,8 @@ get_full_array_size (stmtblock_t *block, tree decl, int rank) If no_malloc is set, only the copy is done. */ static tree -duplicate_allocatable(tree dest, tree src, tree type, int rank, - bool no_malloc) +duplicate_allocatable (tree dest, tree src, tree type, int rank, + bool no_malloc) { tree tmp; tree size; @@ -5803,7 +6022,7 @@ duplicate_allocatable(tree dest, tree src, tree type, int rank, if (rank == 0) { tmp = null_pointer_node; - tmp = fold_build2 (MODIFY_EXPR, type, dest, tmp); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp); gfc_add_expr_to_block (&block, tmp); null_data = gfc_finish_block (&block); @@ -5812,8 +6031,8 @@ duplicate_allocatable(tree dest, tree src, tree type, int rank, if (!no_malloc) { tmp = gfc_call_malloc (&block, type, size); - tmp = fold_build2 (MODIFY_EXPR, void_type_node, dest, - fold_convert (type, tmp)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + dest, fold_convert (type, tmp)); gfc_add_expr_to_block (&block, tmp); } @@ -5830,7 +6049,8 @@ duplicate_allocatable(tree dest, tree src, tree type, int rank, nelems = get_full_array_size (&block, src, rank); tmp = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + nelems, tmp); if (!no_malloc) { tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src)); @@ -5857,8 +6077,8 @@ duplicate_allocatable(tree dest, tree src, tree type, int rank, null_cond = gfc_conv_descriptor_data_get (src); null_cond = convert (pvoid_type_node, null_cond); - null_cond = fold_build2 (NE_EXPR, boolean_type_node, - null_cond, null_pointer_node); + null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + null_cond, null_pointer_node); return build3_v (COND_EXPR, null_cond, tmp, null_data); } @@ -5868,7 +6088,7 @@ duplicate_allocatable(tree dest, tree src, tree type, int rank, tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank) { - return duplicate_allocatable(dest, src, type, rank, false); + return duplicate_allocatable (dest, src, type, rank, false); } @@ -5877,7 +6097,7 @@ gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank) tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) { - return duplicate_allocatable(dest, src, type, rank, true); + return duplicate_allocatable (dest, src, type, rank, true); } @@ -5896,6 +6116,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_loopinfo loop; stmtblock_t fnblock; stmtblock_t loopbody; + tree decl_type; tree tmp; tree comp; tree dcmp; @@ -5909,37 +6130,46 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_init_block (&fnblock); - if (POINTER_TYPE_P (TREE_TYPE (decl)) && rank != 0) + decl_type = TREE_TYPE (decl); + + if ((POINTER_TYPE_P (decl_type) && rank != 0) + || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0)) + decl = build_fold_indirect_ref_loc (input_location, decl); + /* Just in case in gets dereferenced. */ + decl_type = TREE_TYPE (decl); + /* If this an array of derived types with allocatable components build a loop and recursively call this function. */ - if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE - || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + if (TREE_CODE (decl_type) == ARRAY_TYPE + || GFC_DESCRIPTOR_TYPE_P (decl_type)) { tmp = gfc_conv_array_data (decl); var = build_fold_indirect_ref_loc (input_location, tmp); /* Get the number of elements - 1 and set the counter. */ - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + if (GFC_DESCRIPTOR_TYPE_P (decl_type)) { /* Use the descriptor for an allocatable array. Since this is a full array reference, we only need the descriptor information from dimension = rank. */ tmp = get_full_array_size (&fnblock, decl, rank); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); null_cond = gfc_conv_descriptor_data_get (decl); - null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond, - build_int_cst (TREE_TYPE (null_cond), 0)); + null_cond = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, null_cond, + build_int_cst (TREE_TYPE (null_cond), 0)); } else { /* Otherwise use the TYPE_DOMAIN information. */ - tmp = array_type_nelts (TREE_TYPE (decl)); + tmp = array_type_nelts (decl_type); tmp = fold_convert (gfc_array_index_type, tmp); } @@ -5956,7 +6186,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, { if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) { - tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank); + tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank); gfc_add_expr_to_block (&fnblock, tmp); } tmp = build_fold_indirect_ref_loc (input_location, @@ -6010,8 +6240,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, components. */ if (cmp_has_alloc_comps && !c->attr.pointer) { - comp = fold_build3 (COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); rank = c->as ? c->as->rank : 0; tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, rank, purpose); @@ -6020,39 +6250,42 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, if (c->attr.allocatable && c->attr.dimension) { - comp = fold_build3 (COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); tmp = gfc_trans_dealloc_allocated (comp); gfc_add_expr_to_block (&fnblock, tmp); } else if (c->attr.allocatable) { /* Allocatable scalar components. */ - comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL); gfc_add_expr_to_block (&fnblock, tmp); - tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, comp, + build_int_cst (TREE_TYPE (comp), 0)); gfc_add_expr_to_block (&fnblock, tmp); } - else if (c->ts.type == BT_CLASS - && c->ts.u.derived->components->attr.allocatable) + else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) { /* Allocatable scalar CLASS components. */ - comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); /* Add reference to '$data' component. */ - tmp = c->ts.u.derived->components->backend_decl; - comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), - comp, tmp, NULL_TREE); + tmp = CLASS_DATA (c)->backend_decl; + comp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (tmp), comp, tmp, NULL_TREE); tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL); gfc_add_expr_to_block (&fnblock, tmp); - tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, comp, + build_int_cst (TREE_TYPE (comp), 0)); gfc_add_expr_to_block (&fnblock, tmp); } break; @@ -6062,35 +6295,38 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, continue; else if (c->attr.allocatable && c->attr.dimension) { - comp = fold_build3 (COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); } else if (c->attr.allocatable) { /* Allocatable scalar components. */ - comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); - tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, comp, + build_int_cst (TREE_TYPE (comp), 0)); gfc_add_expr_to_block (&fnblock, tmp); } - else if (c->ts.type == BT_CLASS - && c->ts.u.derived->components->attr.allocatable) + else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) { /* Allocatable scalar CLASS components. */ - comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); /* Add reference to '$data' component. */ - tmp = c->ts.u.derived->components->backend_decl; - comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), - comp, tmp, NULL_TREE); - tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); + tmp = CLASS_DATA (c)->backend_decl; + comp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (tmp), comp, tmp, NULL_TREE); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, comp, + build_int_cst (TREE_TYPE (comp), 0)); gfc_add_expr_to_block (&fnblock, tmp); } else if (cmp_has_alloc_comps) { - comp = fold_build3 (COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); rank = c->as ? c->as->rank : 0; tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, rank, purpose); @@ -6103,14 +6339,16 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, continue; /* We need source and destination components. */ - comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); - dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE); + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, + cdecl, NULL_TREE); + dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest, + cdecl, NULL_TREE); dcmp = fold_convert (TREE_TYPE (comp), dcmp); if (c->attr.allocatable && !cmp_has_alloc_comps) { rank = c->as ? c->as->rank : 0; - tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, rank); + tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank); gfc_add_expr_to_block (&fnblock, tmp); } @@ -6176,36 +6414,18 @@ gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) } -/* Check for default initializer; sym->value is not enough as it is also - set for EXPR_NULL of allocatables. */ - -static bool -has_default_initializer (gfc_symbol *der) -{ - gfc_component *c; - - gcc_assert (der->attr.flavor == FL_DERIVED); - for (c = der->components; c; c = c->next) - if ((c->ts.type != BT_DERIVED && c->initializer) - || (c->ts.type == BT_DERIVED - && (!c->attr.pointer && has_default_initializer (c->ts.u.derived)))) - break; - - return c != NULL; -} - - /* NULLIFY an allocatable/pointer array on function entry, free it on exit. 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; @@ -6219,7 +6439,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); @@ -6227,16 +6447,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); @@ -6250,7 +6469,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. */ @@ -6261,17 +6482,16 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) if (!sym->attr.save && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program)) { - if (sym->value == NULL || !has_default_initializer (sym->ts.u.derived)) + if (sym->value == NULL + || !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)) @@ -6279,16 +6499,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. @@ -6299,17 +6518,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 ******************/ @@ -6361,6 +6581,13 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) continue; ar = &ref->u.ar; + + if (ar->as->rank == 0) + { + /* Scalar coarray. */ + continue; + } + switch (ar->type) { case AR_ELEMENT: @@ -6609,6 +6836,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) gfc_intrinsic_sym *isym; gfc_symbol *sym; gfc_component *comp = NULL; + int n; isym = expr->value.function.isym; @@ -6630,6 +6858,8 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) newss->expr = expr; newss->next = ss; newss->data.info.dimen = expr->rank; + for (n = 0; n < newss->data.info.dimen; n++) + newss->data.info.dim[n] = n; return newss; } @@ -6668,7 +6898,7 @@ gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr) /* Walk an expression. Add walked expressions to the head of the SS chain. A wholly scalar expression will not be added. */ -static gfc_ss * +gfc_ss * gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr) { gfc_ss *head; diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index d48d6c8b67b..f363716d3d3 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,12 +58,14 @@ 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 *); /* Generate scalarization information for an expression. */ gfc_ss *gfc_walk_expr (gfc_expr *); +/* Workhorse for gfc_walk_expr. */ +gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *); /* Walk the arguments of an elemental function. */ gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_actual_arglist *, gfc_ss_type); @@ -139,13 +141,20 @@ void gfc_conv_descriptor_stride_set (stmtblock_t *, tree, tree, tree); void gfc_conv_descriptor_lbound_set (stmtblock_t *, tree, tree, tree); void gfc_conv_descriptor_ubound_set (stmtblock_t *, tree, tree, tree); +/* Shift lower bound of descriptor, updating ubound and offset. */ +void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree); + /* Add pre-loop scalarization code for intrinsic functions which require special handling. */ void gfc_add_intrinsic_ss_code (gfc_loopinfo *, gfc_ss *); /* Functions for constant array constructor processing. */ -unsigned HOST_WIDE_INT gfc_constant_array_constructor_p (gfc_constructor *); +unsigned HOST_WIDE_INT gfc_constant_array_constructor_p (gfc_constructor_base); tree gfc_build_constant_array_constructor (gfc_expr *, tree); /* Copy a string from src to dest. */ void gfc_trans_string_copy (stmtblock_t *, tree, tree, int, tree, tree, int); + +/* Calculate extent / size of an array. */ +tree gfc_conv_array_extent_dim (tree, tree, tree*); +tree gfc_conv_descriptor_size (tree, int); diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index 844ac1d2674..486fbbbb3de 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -96,11 +96,10 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "target.h" -#include "tree.h" -#include "toplev.h" #include "tm.h" -#include "rtl.h" +#include "tree.h" +#include "toplev.h" /* For exact_log2. */ +#include "output.h" /* For decl_default_tls_model. */ #include "gfortran.h" #include "trans.h" #include "trans-types.h" @@ -433,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; @@ -609,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) @@ -618,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) @@ -650,8 +649,10 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) { /* Add the initializer for this field. */ tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts, - TREE_TYPE (s->field), s->sym->attr.dimension, - s->sym->attr.pointer || s->sym->attr.allocatable); + TREE_TYPE (s->field), + s->sym->attr.dimension, + s->sym->attr.pointer + || s->sym->attr.allocatable, false); CONSTRUCTOR_APPEND_ELT (v, s->field, tmp); } @@ -702,8 +703,9 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) gfc_add_decl_to_function (var_decl); SET_DECL_VALUE_EXPR (var_decl, - fold_build3 (COMPONENT_REF, TREE_TYPE (s->field), - decl, s->field, NULL_TREE)); + fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (s->field), + decl, s->field, NULL_TREE)); DECL_HAS_VALUE_EXPR_P (var_decl) = 1; GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1; diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c index 74520889d7e..3d8d4ef8e7d 100644 --- a/gcc/fortran/trans-const.c +++ b/gcc/fortran/trans-const.c @@ -1,6 +1,6 @@ /* Translation of constants - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software - Foundation, Inc. + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + Free Software Foundation, Inc. Contributed by Paul Brook This file is part of GCC. @@ -25,9 +25,8 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "ggc.h" -#include "toplev.h" -#include "real.h" +#include "realmpfr.h" +#include "diagnostic-core.h" /* For fatal_error. */ #include "double-int.h" #include "gfortran.h" #include "trans.h" @@ -236,6 +235,26 @@ gfc_conv_mpfr_to_tree (mpfr_t f, int kind, int is_snan) return build_real (type, real); } +/* Returns a real constant that is +Infinity if the target + supports infinities for this floating-point mode, and + +HUGE_VAL otherwise (the largest representable number). */ + +tree +gfc_build_inf_or_huge (tree type, int kind) +{ + if (HONOR_INFINITIES (TYPE_MODE (type))) + { + REAL_VALUE_TYPE real; + real_inf (&real); + return build_real (type, real); + } + else + { + int k = gfc_validate_kind (BT_REAL, kind, false); + return gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge, kind, 0); + } +} + /* Converts a backend tree into a real constant. */ void @@ -267,29 +286,29 @@ gfc_conv_constant_to_tree (gfc_expr * expr) { case BT_INTEGER: if (expr->representation.string) - return fold_build1 (VIEW_CONVERT_EXPR, - gfc_get_int_type (expr->ts.kind), - gfc_build_string_const (expr->representation.length, - expr->representation.string)); + return fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + gfc_get_int_type (expr->ts.kind), + gfc_build_string_const (expr->representation.length, + expr->representation.string)); else return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind); case BT_REAL: if (expr->representation.string) - return fold_build1 (VIEW_CONVERT_EXPR, - gfc_get_real_type (expr->ts.kind), - gfc_build_string_const (expr->representation.length, - expr->representation.string)); + return fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + gfc_get_real_type (expr->ts.kind), + gfc_build_string_const (expr->representation.length, + expr->representation.string)); else return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan); case BT_LOGICAL: if (expr->representation.string) { - tree tmp = fold_build1 (VIEW_CONVERT_EXPR, - gfc_get_int_type (expr->ts.kind), - gfc_build_string_const (expr->representation.length, - expr->representation.string)); + tree tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + gfc_get_int_type (expr->ts.kind), + gfc_build_string_const (expr->representation.length, + expr->representation.string)); if (!integer_zerop (tmp) && !integer_onep (tmp)) gfc_warning ("Assigning value other than 0 or 1 to LOGICAL" " has undefined result at %L", &expr->where); @@ -301,10 +320,10 @@ gfc_conv_constant_to_tree (gfc_expr * expr) case BT_COMPLEX: if (expr->representation.string) - return fold_build1 (VIEW_CONVERT_EXPR, - gfc_get_complex_type (expr->ts.kind), - gfc_build_string_const (expr->representation.length, - expr->representation.string)); + return fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + gfc_get_complex_type (expr->ts.kind), + gfc_build_string_const (expr->representation.length, + expr->representation.string)); else { tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex), @@ -349,14 +368,15 @@ gfc_conv_constant (gfc_se * se, gfc_expr * expr) || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR) { /* Create a new EXPR_CONSTANT expression for our local uses. */ - expr = gfc_int_expr (0); + expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); } } if (expr->expr_type != EXPR_CONSTANT) { + gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); gfc_error ("non-constant initialization expression at %L", &expr->where); - se->expr = gfc_conv_constant_to_tree (gfc_int_expr (0)); + se->expr = gfc_conv_constant_to_tree (e); return; } diff --git a/gcc/fortran/trans-const.h b/gcc/fortran/trans-const.h index 6cc71c5faad..8f567116ee3 100644 --- a/gcc/fortran/trans-const.h +++ b/gcc/fortran/trans-const.h @@ -27,6 +27,10 @@ void gfc_conv_tree_to_mpz (mpz_t, tree); tree gfc_conv_mpfr_to_tree (mpfr_t, int, int); void gfc_conv_tree_to_mpfr (mpfr_ptr, tree); +/* Build a tree containing a real infinity (or HUGE if infinities are + not supported for the given type. */ +tree gfc_build_inf_or_huge (tree, int); + /* Build a tree for a constant. Must be an EXPR_CONSTANT gfc_expr. For CHARACTER literal constants, the caller still has to set the string length as a separate operation. */ diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 53c4b475add..0ff297f7e6b 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -24,13 +24,14 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" +#include "tm.h" #include "tree.h" #include "tree-dump.h" -#include "gimple.h" +#include "gimple.h" /* For create_tmp_var_raw. */ #include "ggc.h" -#include "toplev.h" -#include "tm.h" -#include "rtl.h" +#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" #include "flags.h" @@ -38,6 +39,7 @@ along with GCC; see the file COPYING3. If not see #include "debug.h" #include "gfortran.h" #include "pointer-set.h" +#include "constructor.h" #include "trans.h" #include "trans-types.h" #include "trans-array.h" @@ -53,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. */ @@ -73,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. */ @@ -85,6 +88,7 @@ tree gfor_fndecl_pause_numeric; tree gfor_fndecl_pause_string; tree gfor_fndecl_stop_numeric; tree gfor_fndecl_stop_string; +tree gfor_fndecl_error_stop_numeric; tree gfor_fndecl_error_stop_string; tree gfor_fndecl_runtime_error; tree gfor_fndecl_runtime_error_at; @@ -146,12 +150,9 @@ tree gfor_fndecl_convert_char4_to_char1; /* Other misc. runtime library functions. */ - tree gfor_fndecl_size0; tree gfor_fndecl_size1; tree gfor_fndecl_iargc; -tree gfor_fndecl_clz128; -tree gfor_fndecl_ctz128; /* Intrinsic functions implemented in Fortran. */ tree gfor_fndecl_sc_kind; @@ -171,7 +172,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; } @@ -181,7 +182,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; } @@ -191,7 +192,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; } @@ -234,28 +235,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 @@ -610,8 +589,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) void gfc_allocate_lang_decl (tree decl) { - DECL_LANG_SPECIFIC (decl) = (struct lang_decl *) - ggc_alloc_cleared (sizeof (struct lang_decl)); + DECL_LANG_SPECIFIC (decl) = ggc_alloc_cleared_lang_decl(sizeof + (struct lang_decl)); } /* Remember a symbol to generate initialization/cleanup code at function @@ -676,6 +655,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) tree type; int dim; int nest; + gfc_namespace* procns; type = TREE_TYPE (decl); @@ -684,7 +664,8 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) return; gcc_assert (GFC_ARRAY_TYPE_P (type)); - nest = (sym->ns->proc_name->backend_decl != current_function_decl) + procns = gfc_find_proc_namespace (sym->ns); + nest = (procns->proc_name->backend_decl != current_function_decl) && !sym->attr.contained; for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++) @@ -740,8 +721,8 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) { tree size, range; - size = fold_build2 (MINUS_EXPR, gfc_array_index_type, - GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node); range = build_range_type (gfc_array_index_type, gfc_index_zero_node, size); TYPE_DOMAIN (type) = range; @@ -770,19 +751,33 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) for (dim = sym->as->rank - 1; dim >= 0; dim--) { - rtype = build_range_type (gfc_array_index_type, - GFC_TYPE_ARRAY_LBOUND (type, dim), - GFC_TYPE_ARRAY_UBOUND (type, dim)); + tree lbound, ubound; + lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); + ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); + rtype = build_range_type (gfc_array_index_type, lbound, ubound); gtype = build_array_type (gtype, rtype); - /* Ensure the bound variables aren't optimized out at -O0. */ - if (!optimize) + /* 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 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 (GFC_TYPE_ARRAY_LBOUND (type, dim) - && TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL) - DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0; - if (GFC_TYPE_ARRAY_UBOUND (type, dim) - && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL) - DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0; + if (DECL_NAME (lbound) + && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)), + "lbound") != 0) + DECL_NAMELESS (lbound) = 1; + DECL_IGNORED_P (lbound) = 0; + } + if (ubound && TREE_CODE (ubound) == VAR_DECL + && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound)) + { + if (DECL_NAME (ubound) + && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)), + "ubound") != 0) + DECL_NAMELESS (ubound) = 1; + DECL_IGNORED_P (ubound) = 0; } } TYPE_NAME (type) = type_decl = build_decl (input_location, @@ -883,6 +878,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; @@ -943,7 +939,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; } @@ -1035,6 +1031,9 @@ add_attributes_to_decl (symbol_attribute sym_attr, tree list) } +static void build_function_decl (gfc_symbol * sym, bool global); + + /* Return the decl for a gfc_symbol, create it if it doesn't already exist. */ @@ -1048,13 +1047,23 @@ gfc_get_symbol_decl (gfc_symbol * sym) gcc_assert (sym->attr.referenced || sym->attr.use_assoc - || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY); + || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY + || (sym->module && sym->attr.if_source != IFSRC_DECL + && sym->backend_decl)); if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function) byref = gfc_return_by_reference (sym->ns->proc_name); else byref = 0; + /* Make sure that the vtab for the declared type is completed. */ + if (sym->ts.type == BT_CLASS) + { + gfc_component *c = CLASS_DATA (sym); + if (!c->ts.u.derived->backend_decl) + gfc_find_derived_vtab (c->ts.u.derived); + } + if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref)) { /* Return via extra parameter. */ @@ -1066,7 +1075,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. */ @@ -1124,11 +1133,9 @@ gfc_get_symbol_decl (gfc_symbol * sym) return sym->backend_decl; /* If use associated and whole file compilation, use the module - declaration. This is only needed for intrinsic types because - they are substituted for one another during optimization. */ + declaration. */ if (gfc_option.flag_whole_file && sym->attr.flavor == FL_VARIABLE - && sym->ts.type != BT_DERIVED && sym->attr.use_assoc && sym->module) { @@ -1142,19 +1149,32 @@ gfc_get_symbol_decl (gfc_symbol * sym) gfc_find_symbol (sym->name, gsym->ns, 0, &s); if (s && s->backend_decl) { + if (sym->ts.type == BT_DERIVED) + gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived, + true); if (sym->ts.type == BT_CHARACTER) sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl; - return s->backend_decl; + sym->backend_decl = s->backend_decl; + return sym->backend_decl; } } } - /* Catch function declarations. Only used for actual parameters and - procedure pointers. */ if (sym->attr.flavor == FL_PROCEDURE) { - decl = gfc_get_extern_function_decl (sym); - gfc_set_decl_location (decl, &sym->declared_at); + /* Catch function declarations. Only used for actual parameters, + procedure pointers and procptr initialization targets. */ + if (sym->attr.external || sym->attr.use_assoc || sym->attr.intrinsic) + { + decl = gfc_get_extern_function_decl (sym); + gfc_set_decl_location (decl, &sym->declared_at); + } + else + { + if (!sym->backend_decl) + build_function_decl (sym, false); + decl = sym->backend_decl; + } return decl; } @@ -1189,15 +1209,16 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* Create variables to hold the non-constant bits of array info. */ gfc_build_qualified_array (decl, sym); - if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer) + if (sym->attr.contiguous + || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)) GFC_DECL_PACKED_ARRAY (decl) = 1; } /* Remember this variable for allocation/cleanup. */ if (sym->attr.dimension || sym->attr.allocatable || (sym->ts.type == BT_CLASS && - (sym->ts.u.derived->components->attr.dimension - || sym->ts.u.derived->components->attr.allocatable)) + (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.allocatable)) || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp) /* This applies a derived type default initializer. */ || (sym->ts.type == BT_DERIVED @@ -1269,8 +1290,11 @@ gfc_get_symbol_decl (gfc_symbol * sym) every time the procedure is entered. The TREE_STATIC is in this case due to -fmax-stack-var-size=. */ DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, - TREE_TYPE (decl), sym->attr.dimension, - sym->attr.pointer || sym->attr.allocatable); + TREE_TYPE (decl), + sym->attr.dimension, + sym->attr.pointer + || sym->attr.allocatable, + sym->attr.proc_pointer); } if (!TREE_STATIC (decl) @@ -1357,9 +1381,9 @@ get_proc_pointer_decl (gfc_symbol *sym) { /* Add static initializer. */ DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, - TREE_TYPE (decl), - sym->attr.proc_pointer ? false : sym->attr.dimension, - sym->attr.proc_pointer); + TREE_TYPE (decl), + sym->attr.dimension, + false, true); } attributes = add_attributes_to_decl (sym->attr, NULL_TREE); @@ -1401,12 +1425,30 @@ gfc_get_extern_function_decl (gfc_symbol * sym) gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); if (gfc_option.flag_whole_file - && !sym->attr.use_assoc + && (!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL) && !sym->backend_decl && gsym && gsym->ns && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION)) - && gsym->ns->proc_name->backend_decl) + && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic)) { + if (!gsym->ns->proc_name->backend_decl) + { + /* By construction, the external function cannot be + a contained procedure. */ + locus old_loc; + tree save_fn_decl = current_function_decl; + + current_function_decl = NULL_TREE; + gfc_get_backend_locus (&old_loc); + push_cfun (cfun); + + gfc_create_function_decl (gsym->ns, true); + + pop_cfun (); + gfc_set_backend_locus (&old_loc); + current_function_decl = save_fn_decl; + } + /* If the namespace has entries, the proc_name is the entry master. Find the entry and use its backend_decl. otherwise, use the proc_name backend_decl. */ @@ -1424,12 +1466,17 @@ gfc_get_extern_function_decl (gfc_symbol * sym) } } else - { - sym->backend_decl = gsym->ns->proc_name->backend_decl; - } + sym->backend_decl = gsym->ns->proc_name->backend_decl; if (sym->backend_decl) - return sym->backend_decl; + { + /* Avoid problems of double deallocation of the backend declaration + later in gfc_trans_use_stmts; cf. PR 45087. */ + if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc) + sym->attr.use_assoc = 0; + + return sym->backend_decl; + } } /* See if this is a module procedure from the same file. If so, @@ -1566,16 +1613,18 @@ gfc_get_extern_function_decl (gfc_symbol * sym) a master function with alternate entry points. */ static void -build_function_decl (gfc_symbol * sym) +build_function_decl (gfc_symbol * sym, bool global) { tree fndecl, type, attributes; symbol_attribute attr; tree result_decl; gfc_formal_arglist *f; - gcc_assert (!sym->backend_decl); gcc_assert (!sym->attr.external); + if (sym->backend_decl) + return; + /* Set the line and filename. sym->declared_at seems to point to the last statement for subroutines, but it'll do for now. */ gfc_set_backend_locus (&sym->declared_at); @@ -1674,7 +1723,11 @@ build_function_decl (gfc_symbol * sym) /* Layout the function declaration and put it in the binding level of the current function. */ - pushdecl (fndecl); + + if (global) + pushdecl_top_level (fndecl); + else + pushdecl (fndecl); sym->backend_decl = fndecl; } @@ -1947,7 +2000,7 @@ trans_function_start (gfc_symbol * sym) /* Create thunks for alternate entry points. */ static void -build_entry_thunks (gfc_namespace * ns) +build_entry_thunks (gfc_namespace * ns, bool global) { gfc_formal_arglist *formal; gfc_formal_arglist *thunk_formal; @@ -1955,8 +2008,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; @@ -1966,9 +2017,12 @@ 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); + build_function_decl (thunk_sym, global); create_function_arglist (thunk_sym); trans_function_start (thunk_sym); @@ -1979,18 +2033,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)); } } @@ -2014,31 +2066,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; @@ -2055,19 +2105,20 @@ build_entry_thunks (gfc_namespace * ns) pushdecl (union_decl); DECL_CONTEXT (union_decl) = current_function_decl; - tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl), - union_decl, tmp); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (union_decl), union_decl, tmp); 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; gcc_assert (field != NULL_TREE); - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), - union_decl, field, NULL_TREE); - tmp = fold_build2 (MODIFY_EXPR, + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), union_decl, field, + NULL_TREE); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (DECL_RESULT (current_function_decl)), DECL_RESULT (current_function_decl), tmp); tmp = build1_v (RETURN_EXPR, tmp); @@ -2075,7 +2126,7 @@ build_entry_thunks (gfc_namespace * ns) else if (TREE_TYPE (DECL_RESULT (current_function_decl)) != void_type_node) { - tmp = fold_build2 (MODIFY_EXPR, + tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (DECL_RESULT (current_function_decl)), DECL_RESULT (current_function_decl), tmp); tmp = build1_v (RETURN_EXPR, tmp); @@ -2132,17 +2183,18 @@ build_entry_thunks (gfc_namespace * ns) /* Create a decl for a function, and create any thunks for alternate entry - points. */ + points. If global is true, generate the function in the global binding + level, otherwise in the current binding level (which can be global). */ void -gfc_create_function_decl (gfc_namespace * ns) +gfc_create_function_decl (gfc_namespace * ns, bool global) { /* Create a declaration for the master function. */ - build_function_decl (ns->proc_name); + build_function_decl (ns->proc_name, global); /* Compile the entry thunks. */ if (ns->entries) - build_entry_thunks (ns); + build_entry_thunks (ns, global); /* Now create the read argument list. */ create_function_arglist (ns->proc_name); @@ -2196,14 +2248,14 @@ 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; gcc_assert (field != NULL_TREE); - decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field), - decl, field, NULL_TREE); + decl = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), decl, field, NULL_TREE); } var = create_tmp_var_raw (TREE_TYPE (decl), sym->name); @@ -2247,7 +2299,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) @@ -2259,11 +2311,11 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag) IDENTIFIER_POINTER (DECL_NAME (this_function_decl))); if (!sym->attr.mixed_entry_master && sym->attr.function) - decl = build_decl (input_location, + decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl), VAR_DECL, get_identifier (name), gfc_sym_type (sym)); else - decl = build_decl (input_location, + decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl), VAR_DECL, get_identifier (name), TREE_TYPE (TREE_TYPE (this_function_decl))); DECL_ARTIFICIAL (decl) = 1; @@ -2293,22 +2345,19 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag) /* Builds a function decl. The remaining parameters are the types of the function arguments. Negative nargs indicates a varargs function. */ -tree -gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...) +static tree +build_library_function_decl_1 (tree name, const char *spec, + tree rettype, int nargs, va_list p) { tree arglist; tree argtype; tree fntype; tree fndecl; - va_list p; int n; /* Library functions must be declared with global scope. */ gcc_assert (current_function_decl == NULL_TREE); - va_start (p, nargs); - - /* Create a list of the argument types. */ for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--) { @@ -2319,11 +2368,19 @@ gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...) if (nargs >= 0) { /* Terminate the list. */ - arglist = gfc_chainon_list (arglist, void_type_node); + arglist = chainon (arglist, void_list_node); } /* Build the function type and decl. */ fntype = build_function_type (rettype, arglist); + if (spec) + { + tree attr_args = build_tree_list (NULL_TREE, + build_string (strlen (spec), spec)); + tree attrs = tree_cons (get_identifier ("fn spec"), + attr_args, TYPE_ATTRIBUTES (fntype)); + fntype = build_type_attribute_variant (fntype, attrs); + } fndecl = build_decl (input_location, FUNCTION_DECL, name, fntype); @@ -2331,8 +2388,6 @@ gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...) DECL_EXTERNAL (fndecl) = 1; TREE_PUBLIC (fndecl) = 1; - va_end (p); - pushdecl (fndecl); rest_of_decl_compilation (fndecl, 1, 0); @@ -2340,6 +2395,37 @@ gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...) return fndecl; } +/* Builds a function decl. The remaining parameters are the types of the + function arguments. Negative nargs indicates a varargs function. */ + +tree +gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...) +{ + tree ret; + va_list args; + va_start (args, nargs); + ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args); + va_end (args); + return ret; +} + +/* Builds a function decl. The remaining parameters are the types of the + function arguments. Negative nargs indicates a varargs function. + The SPEC parameter specifies the function argument and return type + specification according to the fnspec function type attribute. */ + +tree +gfc_build_library_function_decl_with_spec (tree name, const char *spec, + tree rettype, int nargs, ...) +{ + tree ret; + va_list args; + va_start (args, nargs); + ret = build_library_function_decl_1 (name, spec, rettype, nargs, args); + va_end (args); + return ret; +} + static void gfc_build_intrinsic_function_decls (void) { @@ -2351,211 +2437,197 @@ 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_int4_type_node, 2, - gfc_charlen_type_node, pchar1_type_node); - - gfor_fndecl_string_index = - gfc_build_library_function_decl (get_identifier (PREFIX("string_index")), - gfc_int4_type_node, 5, - gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node, - gfc_logical4_type_node); - - gfor_fndecl_string_scan = - gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")), - gfc_int4_type_node, 5, - gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node, - gfc_logical4_type_node); - - gfor_fndecl_string_verify = - gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")), - gfc_int4_type_node, 5, - gfc_charlen_type_node, 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; + TREE_NOTHROW (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); + TREE_NOTHROW (gfor_fndecl_concat_string) = 1; + + 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; + TREE_NOTHROW (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; + TREE_NOTHROW (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; + TREE_NOTHROW (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; + TREE_NOTHROW (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); + TREE_NOTHROW (gfor_fndecl_adjustl) = 1; + + 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); + TREE_NOTHROW (gfor_fndecl_adjustr) = 1; + + 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; + TREE_NOTHROW (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; + TREE_NOTHROW (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); + TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1; + + 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; + TREE_NOTHROW (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; + TREE_NOTHROW (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; + TREE_NOTHROW (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; + TREE_NOTHROW (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); + TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1; + + 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); + TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1; + + 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; + TREE_NOTHROW (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_kind")), - gfc_int4_type_node, 2, - 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; + TREE_NOTHROW (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; + TREE_NOTHROW (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; + TREE_NOTHROW (gfor_fndecl_sr_kind) = 1; /* Power functions. */ { @@ -2582,6 +2654,7 @@ gfc_build_intrinsic_function_decls (void) gfc_build_library_function_decl (get_identifier (name), jtype, 2, jtype, itype); TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1; + TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1; } } @@ -2596,6 +2669,7 @@ gfc_build_intrinsic_function_decls (void) gfc_build_library_function_decl (get_identifier (name), rtype, 2, rtype, itype); TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1; + TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1; } ctype = gfc_get_complex_type (rkinds[rkind]); @@ -2607,6 +2681,7 @@ gfc_build_intrinsic_function_decls (void) gfc_build_library_function_decl (get_identifier (name), ctype, 2,ctype, itype); TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1; + TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1; } } } @@ -2614,23 +2689,29 @@ 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); + TREE_READONLY (gfor_fndecl_math_ishftc4) = 1; + TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1; + + 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); + TREE_READONLY (gfor_fndecl_math_ishftc8) = 1; + TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1; + 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); + TREE_READONLY (gfor_fndecl_math_ishftc16) = 1; + TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1; + } /* BLAS functions. */ { @@ -2676,33 +2757,21 @@ 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); - - 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_ctz128 = - gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")), - integer_type_node, 1, uint128); - } + 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; + TREE_NOTHROW (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; + TREE_NOTHROW (gfor_fndecl_size1) = 1; + + gfor_fndecl_iargc = gfc_build_library_function_decl ( + get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0); + TREE_NOTHROW (gfor_fndecl_iargc) = 1; } @@ -2713,103 +2782,105 @@ 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); - /* Stop doesn't return. */ + 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); - /* Stop doesn't return. */ + 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_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_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_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 ( - get_identifier (PREFIX("internal_pack")), - pvoid_type_node, 1, pvoid_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); - gfor_fndecl_in_unpack = gfc_build_library_function_decl ( - get_identifier (PREFIX("internal_unpack")), - void_type_node, 2, pvoid_type_node, 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); - 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; + TREE_NOTHROW (gfor_fndecl_associated) = 1; gfc_build_intrinsic_function_decls (); gfc_build_intrinsic_lib_fndecls (); @@ -2819,72 +2890,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); + tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl); + 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 @@ -2997,15 +3066,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); @@ -3014,14 +3083,11 @@ gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc) || sym->ns->proc_name->attr.entry_master)) { present = gfc_conv_expr_present (sym); - tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, - tmp, build_empty_stmt (input_location)); + tmp = build3_loc (input_location, 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); } @@ -3029,15 +3095,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 @@ -3053,18 +3119,103 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body) || f->sym->ns->proc_name->attr.entry_master) { present = gfc_conv_expr_present (f->sym); - tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, - tmp, build_empty_stmt (input_location)); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), + present, 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); +} + + +/* Do proper initialization for ASSOCIATE names. */ + +static void +trans_associate_var (gfc_symbol* sym, gfc_wrapped_block* block) +{ + gfc_expr* e; + tree tmp; + + gcc_assert (sym->assoc); + e = sym->assoc->target; + + /* Do a `pointer assignment' with updated descriptor (or assign descriptor + to array temporary) for arrays with either unknown shape or if associating + to a variable. */ + if (sym->attr.dimension + && (sym->as->type == AS_DEFERRED || sym->assoc->variable)) + { + gfc_se se; + gfc_ss* ss; + tree desc; + + desc = sym->backend_decl; + + /* If association is to an expression, evaluate it and create temporary. + Otherwise, get descriptor of target for pointer assignment. */ + gfc_init_se (&se, NULL); + ss = gfc_walk_expr (e); + if (sym->assoc->variable) + { + se.direct_byref = 1; + se.expr = desc; + } + gfc_conv_expr_descriptor (&se, e, ss); + + /* If we didn't already do the pointer assignment, set associate-name + descriptor to the one generated for the temporary. */ + if (!sym->assoc->variable) + { + int dim; + + gfc_add_modify (&se.pre, desc, se.expr); + + /* The generated descriptor has lower bound zero (as array + temporary), shift bounds so we get lower bounds of 1. */ + for (dim = 0; dim < e->rank; ++dim) + gfc_conv_shift_descriptor_lbound (&se.pre, desc, + dim, gfc_index_one_node); + } + + /* Done, register stuff as init / cleanup code. */ + gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), + gfc_finish_block (&se.post)); + } + + /* Do a scalar pointer assignment; this is for scalar variable targets. */ + else if (gfc_is_associate_pointer (sym)) + { + gfc_se se; + + gcc_assert (!sym->attr.dimension); + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, e); + + tmp = TREE_TYPE (sym->backend_decl); + tmp = gfc_build_addr_expr (tmp, se.expr); + gfc_add_modify (&se.pre, sym->backend_decl, tmp); + + gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), + gfc_finish_block (&se.post)); + } + + /* Do a simple assignment. This is for scalar expressions, where we + can simply use expression assignment. */ + else + { + gfc_expr* lhs; + + lhs = gfc_lval_expr_from_sym (sym); + tmp = gfc_trans_assignment (lhs, e, false, true); + gfc_add_init_cleanup (block, tmp, NULL_TREE); + } } @@ -3074,15 +3225,16 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body) Allocation of character string variables. Initialization and possibly repacking of dummy arrays. Initialization of ASSIGN statement auxiliary variable. + Initialization of ASSOCIATE names. 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 @@ -3106,19 +3258,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 @@ -3128,20 +3278,21 @@ 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) { bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED) && sym->ts.u.derived->attr.alloc_comp; - if (sym->attr.dimension) + if (sym->assoc) + trans_associate_var (sym, block); + else if (sym->attr.dimension) { switch (sym->as->type) { 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)) @@ -3149,7 +3300,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 @@ -3157,18 +3308,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; @@ -3179,33 +3336,30 @@ 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_has_alloc_comp) - fnbody = gfc_trans_deferred_array (sym, fnbody); else if (sym->attr.allocatable || (sym->ts.type == BT_CLASS - && sym->ts.u.derived->components->attr.allocatable)) + && CLASS_DATA (sym)->attr.allocatable)) { if (!sym->attr.save) { @@ -3214,7 +3368,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) @@ -3226,47 +3380,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) + 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) { @@ -3274,7 +3435,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); } } @@ -3283,11 +3444,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; @@ -3342,7 +3502,7 @@ gfc_find_module (const char *name) htab_hash_string (name), INSERT); if (*slot == NULL) { - struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry); + struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry (); entry->name = gfc_get_string (name); entry->decls = htab_create_ggc (10, module_htab_decls_hash, @@ -3439,7 +3599,7 @@ gfc_create_module_variable (gfc_symbol * sym) && (sym->equiv_built || sym->attr.in_equivalence)) return; - if (sym->backend_decl && !sym->attr.vtab) + if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target) internal_error ("backend decl for module variable %s already exists", sym->name); @@ -3462,7 +3622,8 @@ gfc_create_module_variable (gfc_symbol * sym) tree length; length = sym->ts.u.cl->backend_decl; - if (!INTEGER_CST_P (length)) + gcc_assert (length || sym->attr.proc_pointer); + if (length && !INTEGER_CST_P (length)) { pushdecl (length); rest_of_decl_compilation (length, 1, 0); @@ -3578,7 +3739,8 @@ check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array, return check_constant_initializer (expr, ts, false, false); else if (expr->expr_type != EXPR_ARRAY) return false; - for (c = expr->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) { if (c->iterator) return false; @@ -3598,7 +3760,8 @@ check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array, if (expr->expr_type != EXPR_STRUCTURE) return false; cm = expr->ts.u.derived->components; - for (c = expr->value.constructor; c; c = c->next, cm = cm->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c), cm = cm->next) { if (!c->expr || cm->attr.allocatable) continue; @@ -3682,9 +3845,10 @@ gfc_emit_parameter_debug_info (gfc_symbol *sym) TREE_USED (decl) = 1; if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL) TREE_PUBLIC (decl) = 1; - DECL_INITIAL (decl) - = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl), - sym->attr.dimension, 0); + DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, + TREE_TYPE (decl), + sym->attr.dimension, + false, false); debug_hooks->global_decl (decl); } @@ -3724,7 +3888,7 @@ gfc_generate_contained_functions (gfc_namespace * parent) if (ns->parent != parent) continue; - gfc_create_function_decl (ns); + gfc_create_function_decl (ns, false); } for (ns = parent->contained; ns; ns = ns->sibling) @@ -3806,20 +3970,29 @@ generate_local_decl (gfc_symbol * sym) if (sym->attr.referenced) gfc_get_symbol_decl (sym); - /* INTENT(out) dummy arguments are likely meant to be set. */ - else if (warn_unused_variable - && sym->attr.dummy - && sym->attr.intent == INTENT_OUT) + + /* Warnings for unused dummy arguments. */ + else if (sym->attr.dummy) { - if (!(sym->ts.type == BT_DERIVED - && sym->ts.u.derived->components->initializer)) - gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) " - "but was not set", sym->name, &sym->declared_at); + /* INTENT(out) dummy arguments are likely meant to be set. */ + if (gfc_option.warn_unused_dummy_argument + && sym->attr.intent == INTENT_OUT) + { + if (sym->ts.type != BT_DERIVED) + gfc_warning ("Dummy argument '%s' at %L was declared " + "INTENT(OUT) but was not set", sym->name, + &sym->declared_at); + else if (!gfc_has_default_initializer (sym->ts.u.derived)) + gfc_warning ("Derived-type dummy argument '%s' at %L was " + "declared INTENT(OUT) but was not set and " + "does not have a default initializer", + sym->name, &sym->declared_at); + } + else if (gfc_option.warn_unused_dummy_argument) + gfc_warning ("Unused dummy argument '%s' at %L", sym->name, + &sym->declared_at); } - /* Specific warning for unused dummy arguments. */ - else if (warn_unused_variable && sym->attr.dummy) - gfc_warning ("Unused dummy argument '%s' at %L", sym->name, - &sym->declared_at); + /* Warn for unused variables, but not if they're inside a common block or are use-associated. */ else if (warn_unused_variable @@ -4009,27 +4182,29 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym) /* Build the condition. For optional arguments, an actual length of 0 is also acceptable if the associated string is NULL, which means the argument was not passed. */ - cond = fold_build2 (comparison, boolean_type_node, - cl->passed_length, cl->backend_decl); + cond = fold_build2_loc (input_location, comparison, boolean_type_node, + cl->passed_length, cl->backend_decl); if (fsym->attr.optional) { tree not_absent; tree not_0length; tree absent_failed; - not_0length = fold_build2 (NE_EXPR, boolean_type_node, - cl->passed_length, - fold_convert (gfc_charlen_type_node, - integer_zero_node)); + not_0length = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + cl->passed_length, + fold_convert (gfc_charlen_type_node, + integer_zero_node)); /* The symbol needs to be referenced for gfc_get_symbol_decl. */ fsym->attr.referenced = 1; not_absent = gfc_conv_expr_present (fsym); - absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, - not_0length, not_absent); + absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, not_0length, + not_absent); - cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - cond, absent_failed); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, cond, absent_failed); } /* Build the runtime check. */ @@ -4135,6 +4310,7 @@ create_main_function (tree fndecl) language standard parameters. */ { tree array_type, array, var; + VEC(constructor_elt,gc) *v = NULL; /* Passing a new option to the library requires four modifications: + add it to the tree_cons list below @@ -4143,28 +4319,34 @@ create_main_function (tree fndecl) gfor_fndecl_set_options + modify the library (runtime/compile_options.c)! */ - array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, - gfc_option.warn_std), NULL_TREE); - array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, - gfc_option.allow_std), array); - array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic), - array); - array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, - gfc_option.flag_dump_core), array); - array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, - gfc_option.flag_backtrace), array); - array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, - gfc_option.flag_sign_zero), array); - - array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, - (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array); - - array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, - gfc_option.flag_range_check), array); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + gfc_option.warn_std)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + gfc_option.allow_std)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, pedantic)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + gfc_option.flag_dump_core)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + gfc_option.flag_backtrace)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + gfc_option.flag_sign_zero)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + (gfc_option.rtcheck + & GFC_RTCHECK_BOUNDS))); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + gfc_option.flag_range_check)); array_type = build_array_type (integer_type_node, build_index_type (build_int_cst (NULL_TREE, 7))); - array = build_constructor_from_list (array_type, nreverse (array)); + array = build_constructor (array_type, v); TREE_CONSTANT (array) = 1; TREE_STATIC (array) = 1; @@ -4235,8 +4417,9 @@ create_main_function (tree fndecl) TREE_USED (fndecl) = 1; /* "return 0". */ - tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main), - build_int_cst (integer_type_node, 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node, + DECL_RESULT (ftn_main), + build_int_cst (integer_type_node, 0)); tmp = build1_v (RETURN_EXPR, tmp); gfc_add_expr_to_block (&body, tmp); @@ -4266,6 +4449,57 @@ 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_loc (input_location, MODIFY_EXPR, + TREE_TYPE (result), DECL_RESULT (fndecl), + result); + } + } + + return build1_v (RETURN_EXPR, result); +} + + /* Generate code for a function. */ void @@ -4275,16 +4509,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); @@ -4292,7 +4528,7 @@ gfc_generate_function_code (gfc_namespace * ns) /* Create the declaration for functions with global scope. */ if (!sym->backend_decl) - gfc_create_function_decl (ns); + gfc_create_function_decl (ns, false); fndecl = sym->backend_decl; old_context = current_function_decl; @@ -4306,7 +4542,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) { @@ -4345,34 +4581,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); @@ -4395,29 +4629,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 @@ -4427,24 +4641,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) @@ -4457,31 +4659,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; @@ -4489,14 +4688,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. */ @@ -4547,6 +4746,8 @@ gfc_generate_function_code (gfc_namespace * ns) if (sym->attr.is_main_program) create_main_function (fndecl); + + current_procedure_symbol = previous_procedure_symbol; } @@ -4565,8 +4766,7 @@ gfc_generate_constructors (void) return; fnname = get_file_function_name ("I"); - type = build_function_type (void_type_node, - gfc_chainon_list (NULL_TREE, void_type_node)); + type = build_function_type_list (void_type_node, NULL_TREE); fndecl = build_decl (input_location, FUNCTION_DECL, fnname, type); @@ -4657,20 +4857,29 @@ gfc_generate_block_data (gfc_namespace * ns) /* Process the local variables of a BLOCK construct. */ void -gfc_process_block_locals (gfc_namespace* ns) +gfc_process_block_locals (gfc_namespace* ns, gfc_association_list* assoc) { tree decl; gcc_assert (saved_local_decls == NULL_TREE); generate_local_vars (ns); + /* Mark associate names to be initialized. The symbol's namespace may not + be the BLOCK's, we have to force this so that the deferring + works as expected. */ + for (; assoc; assoc = assoc->next) + { + assoc->st->n.sym->ns = ns; + gfc_defer_symbol_init (assoc->st->n.sym); + } + decl = saved_local_decls; while (decl) { 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 7e95ce11390..8d4295fce8f 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -26,15 +26,12 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "convert.h" -#include "ggc.h" -#include "toplev.h" -#include "real.h" -#include "gimple.h" +#include "diagnostic-core.h" /* For fatal_error. */ #include "langhooks.h" #include "flags.h" #include "gfortran.h" #include "arith.h" +#include "constructor.h" #include "trans.h" #include "trans-const.h" #include "trans-types.h" @@ -126,7 +123,7 @@ gfc_make_safe_expr (gfc_se * se) tree gfc_conv_expr_present (gfc_symbol * sym) { - tree decl; + tree decl, cond; gcc_assert (sym->attr.dummy); @@ -139,8 +136,27 @@ gfc_conv_expr_present (gfc_symbol * sym) || GFC_ARRAY_TYPE_P (TREE_TYPE (decl))); decl = GFC_DECL_SAVED_DESCRIPTOR (decl); } - return fold_build2 (NE_EXPR, boolean_type_node, decl, - fold_convert (TREE_TYPE (decl), null_pointer_node)); + + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl, + fold_convert (TREE_TYPE (decl), null_pointer_node)); + + /* Fortran 2008 allows to pass null pointers and non-associated pointers + as actual argument to denote absent dummies. For array descriptors, + we thus also need to check the array descriptor. */ + if (!sym->attr.pointer && !sym->attr.allocatable + && sym->as && sym->as->type == AS_ASSUMED_SHAPE + && (gfc_option.allow_std & GFC_STD_F2008) != 0) + { + tree tmp; + tmp = build_fold_indirect_ref_loc (input_location, decl); + tmp = gfc_conv_array_data (tmp); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, + fold_convert (TREE_TYPE (tmp), null_pointer_node)); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond, tmp); + } + + return cond; } @@ -162,15 +178,16 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind) se->expr)); /* Test for a NULL value. */ - tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp, - fold_convert (TREE_TYPE (tmp), integer_one_node)); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present, + tmp, fold_convert (TREE_TYPE (tmp), integer_one_node)); tmp = gfc_evaluate_now (tmp, &se->pre); se->expr = gfc_build_addr_expr (NULL_TREE, tmp); } else { - tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr, - fold_convert (TREE_TYPE (se->expr), integer_zero_node)); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr), + present, se->expr, + fold_convert (TREE_TYPE (se->expr), integer_zero_node)); tmp = gfc_evaluate_now (tmp, &se->pre); se->expr = tmp; } @@ -178,8 +195,8 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind) if (ts.type == BT_CHARACTER) { tmp = build_int_cst (gfc_charlen_type_node, 0); - tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node, - present, se->string_length, tmp); + tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node, + present, se->string_length, tmp); tmp = gfc_evaluate_now (tmp, &se->pre); se->string_length = tmp; } @@ -278,11 +295,14 @@ flatten_array_ctors_without_strlen (gfc_expr* e) /* We've found what we're looking for. */ if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length) { + gfc_constructor *c; gfc_expr* new_expr; + gcc_assert (e->value.constructor); - new_expr = e->value.constructor->expr; - e->value.constructor->expr = NULL; + c = gfc_constructor_first (e->value.constructor); + new_expr = c->expr; + c->expr = NULL; flatten_array_ctors_without_strlen (new_expr); gfc_replace_expr (e, new_expr); @@ -291,7 +311,8 @@ flatten_array_ctors_without_strlen (gfc_expr* e) /* Otherwise, fall through to handle constructor elements. */ case EXPR_STRUCTURE: - for (c = e->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) flatten_array_ctors_without_strlen (c->expr); break; @@ -339,8 +360,8 @@ gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock) gcc_assert (cl->length); gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node); - se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr, - build_int_cst (gfc_charlen_type_node, 0)); + se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, + se.expr, build_int_cst (gfc_charlen_type_node, 0)); gfc_add_block_to_block (pblock, &se.pre); if (cl->backend_decl) @@ -404,14 +425,16 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) { - tree nonempty = fold_build2 (LE_EXPR, boolean_type_node, - start.expr, end.expr); + tree nonempty = fold_build2_loc (input_location, LE_EXPR, + boolean_type_node, start.expr, + end.expr); /* Check lower bound. */ - fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr, - build_int_cst (gfc_charlen_type_node, 1)); - fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node, - nonempty, fault); + fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + start.expr, + build_int_cst (gfc_charlen_type_node, 1)); + fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, nonempty, fault); if (name) asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' " "is less than one", name); @@ -424,10 +447,10 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, gfc_free (msg); /* Check upper bound. */ - fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr, - se->string_length); - fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node, - nonempty, fault); + fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + end.expr, se->string_length); + fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, nonempty, fault); if (name) asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' " "exceeds string length (%%ld)", name); @@ -441,12 +464,20 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, gfc_free (msg); } - tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, - end.expr, start.expr); - tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, - build_int_cst (gfc_charlen_type_node, 1), tmp); - tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp, - build_int_cst (gfc_charlen_type_node, 0)); + /* If the start and end expressions are equal, the length is one. */ + if (ref->u.ss.end + && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0) + tmp = build_int_cst (gfc_charlen_type_node, 1); + else + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node, + end.expr, start.expr); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node, + build_int_cst (gfc_charlen_type_node, 1), tmp); + tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, + tmp, build_int_cst (gfc_charlen_type_node, 0)); + } + se->string_length = tmp; } @@ -468,7 +499,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) field = c->backend_decl; gcc_assert (TREE_CODE (field) == FIELD_DECL); decl = se->expr; - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + decl, field, NULL_TREE); se->expr = tmp; @@ -537,7 +569,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) { gfc_ref *ref; gfc_symbol *sym; - tree parent_decl; + tree parent_decl = NULL_TREE; int parent_flag; bool return_value; bool alternate_entry; @@ -571,7 +603,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) entry_master = sym->attr.result && sym->ns->proc_name->attr.entry_master && !gfc_return_by_reference (sym->ns->proc_name); - parent_decl = DECL_CONTEXT (current_function_decl); + if (current_function_decl) + parent_decl = DECL_CONTEXT (current_function_decl); if ((se->expr == parent_decl && return_value) || (sym->ns && sym->ns->proc_name @@ -653,9 +686,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - /* Dereference non-character pointer variables. + /* Dereference non-character pointer variables. These must be dummies, results, or scalars. */ - if ((sym->attr.pointer || sym->attr.allocatable) + if ((sym->attr.pointer || sym->attr.allocatable + || gfc_is_associate_pointer (sym)) && (sym->attr.dummy || sym->attr.function || sym->attr.result @@ -748,10 +782,10 @@ gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr) We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)). All other unary operators have an equivalent GIMPLE unary operator. */ if (code == TRUTH_NOT_EXPR) - se->expr = fold_build2 (EQ_EXPR, type, operand.expr, - build_int_cst (type, 0)); + se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr, + build_int_cst (type, 0)); else - se->expr = fold_build1 (code, type, operand.expr); + se->expr = fold_build1_loc (input_location, code, type, operand.expr); } @@ -838,7 +872,7 @@ gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar) op1 = op0; } - tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1); + tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1); tmp = gfc_evaluate_now (tmp, &se->pre); if (n < POWI_TABLE_SIZE) @@ -889,27 +923,29 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs) /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */ if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE)) { - tmp = fold_build2 (EQ_EXPR, boolean_type_node, - lhs, build_int_cst (TREE_TYPE (lhs), -1)); - cond = fold_build2 (EQ_EXPR, boolean_type_node, - lhs, build_int_cst (TREE_TYPE (lhs), 1)); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + lhs, build_int_cst (TREE_TYPE (lhs), -1)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + lhs, build_int_cst (TREE_TYPE (lhs), 1)); /* If rhs is even, result = (lhs == 1 || lhs == -1) ? 1 : 0. */ if ((n & 1) == 0) { - tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond); - se->expr = fold_build3 (COND_EXPR, type, - tmp, build_int_cst (type, 1), - build_int_cst (type, 0)); + tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, tmp, cond); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, + tmp, build_int_cst (type, 1), + build_int_cst (type, 0)); return 1; } /* If rhs is odd, result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */ - tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1), - build_int_cst (type, 0)); - se->expr = fold_build3 (COND_EXPR, type, - cond, build_int_cst (type, 1), tmp); + tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, + build_int_cst (type, -1), + build_int_cst (type, 0)); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, + cond, build_int_cst (type, 1), tmp); return 1; } @@ -918,7 +954,8 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs) if (sgn == -1) { tmp = gfc_build_const (type, integer_one_node); - vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]); + vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp, + vartmp[1]); } se->expr = gfc_conv_powi (se, n, vartmp); @@ -937,7 +974,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) int ikind; gfc_se lse; gfc_se rse; - tree fndecl; + tree fndecl = NULL; gfc_init_se (&lse, se); gfc_conv_expr_val (&lse, expr->value.op.op1); @@ -1035,15 +1072,24 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) break; case 2: - case 3: fndecl = built_in_decls[BUILT_IN_POWIL]; break; + case 3: + /* Use the __builtin_powil() only if real(kind=16) is + actually the C long double type. */ + if (!gfc_real16_is_float128) + fndecl = built_in_decls[BUILT_IN_POWIL]; + break; + default: gcc_unreachable (); } } - else + + /* If we don't have a good builtin for this, go for the + library function. */ + if (!fndecl) fndecl = gfor_fndecl_math_powi[kind][ikind].real; break; @@ -1057,39 +1103,11 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) break; case BT_REAL: - switch (kind) - { - case 4: - fndecl = built_in_decls[BUILT_IN_POWF]; - break; - case 8: - fndecl = built_in_decls[BUILT_IN_POW]; - break; - case 10: - case 16: - fndecl = built_in_decls[BUILT_IN_POWL]; - break; - default: - gcc_unreachable (); - } + fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind); break; case BT_COMPLEX: - switch (kind) - { - case 4: - fndecl = built_in_decls[BUILT_IN_CPOWF]; - break; - case 8: - fndecl = built_in_decls[BUILT_IN_CPOW]; - break; - case 10: - case 16: - fndecl = built_in_decls[BUILT_IN_CPOWL]; - break; - default: - gcc_unreachable (); - } + fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind); break; default: @@ -1110,13 +1128,12 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) tree var; tree tmp; - gcc_assert (types_compatible_p (TREE_TYPE (len), gfc_charlen_type_node)); - if (gfc_can_put_var_on_stack (len)) { /* Create a temporary variable to hold the result. */ - tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len, - build_int_cst (gfc_charlen_type_node, 1)); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_charlen_type_node, len, + build_int_cst (gfc_charlen_type_node, 1)); tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE) @@ -1132,9 +1149,10 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) /* Allocate a temporary to hold the result. */ var = gfc_create_var (type, "pstr"); tmp = gfc_call_malloc (&se->pre, type, - fold_build2 (MULT_EXPR, TREE_TYPE (len), len, - fold_convert (TREE_TYPE (len), - TYPE_SIZE (type)))); + fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (len), len, + fold_convert (TREE_TYPE (len), + TYPE_SIZE (type)))); gfc_add_modify (&se->pre, var, tmp); /* Free the temporary afterwards. */ @@ -1173,8 +1191,9 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) len = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); if (len == NULL_TREE) { - len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length), - lse.string_length, rse.string_length); + len = fold_build2_loc (input_location, PLUS_EXPR, + TREE_TYPE (lse.string_length), + lse.string_length, rse.string_length); } type = build_pointer_type (type); @@ -1366,7 +1385,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); } @@ -1376,11 +1396,12 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) if (lop) { /* The result of logical ops is always boolean_type_node. */ - tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr); + tmp = fold_build2_loc (input_location, code, boolean_type_node, + lse.expr, rse.expr); se->expr = convert (type, tmp); } else - se->expr = fold_build2 (code, type, lse.expr, rse.expr); + se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr); /* Add the post blocks. */ gfc_add_block_to_block (&se->post, &rse.post); @@ -1389,17 +1410,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; @@ -1432,7 +1481,8 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) gfc_typespec ts; gfc_clear_ts (&ts); - *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]); + *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, + (int)(*expr)->value.character.string[0]); if ((*expr)->ts.kind != gfc_c_int_kind) { /* The expr needs to be compatible with a C int. If the @@ -1446,7 +1496,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 +1506,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 +1516,92 @@ 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_loc (input_location, MINUS_EXPR, integer_type_node, + sc1, sc2); + } + + 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; + } + + /* 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 - { - /* 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); - } + gcc_unreachable (); - return tmp; + return build_call_expr_loc (input_location, fndecl, 4, + len1, str1, len2, str2); } @@ -1526,141 +1621,11 @@ get_proc_ptr_comp (gfc_expr *e) } -/* Select a class typebound procedure at runtime. */ -static void -select_class_proc (gfc_se *se, gfc_class_esym_list *elist, - tree declared, gfc_expr *expr) -{ - tree end_label; - tree label; - tree tmp; - tree hash; - stmtblock_t body; - gfc_class_esym_list *next_elist, *tmp_elist; - gfc_se tmpse; - - /* Convert the hash expression. */ - gfc_init_se (&tmpse, NULL); - gfc_conv_expr (&tmpse, elist->hash_value); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - hash = gfc_evaluate_now (tmpse.expr, &se->pre); - gfc_add_block_to_block (&se->post, &tmpse.post); - - /* Fix the function type to be that of the declared type method. */ - declared = gfc_create_var (TREE_TYPE (declared), "method"); - - end_label = gfc_build_label_decl (NULL_TREE); - - gfc_init_block (&body); - - /* Go through the list of extensions. */ - for (; elist; elist = next_elist) - { - /* This case has already been added. */ - if (elist->derived == NULL) - goto free_elist; - - /* Skip abstract base types. */ - if (elist->derived->attr.abstract) - goto free_elist; - - /* Run through the chain picking up all the cases that call the - same procedure. */ - tmp_elist = elist; - for (; elist; elist = elist->next) - { - tree cval; - - if (elist->esym != tmp_elist->esym) - continue; - - cval = build_int_cst (TREE_TYPE (hash), - elist->derived->hash_value); - /* Build a label for the hash value. */ - label = gfc_build_label_decl (NULL_TREE); - tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, - cval, NULL_TREE, label); - gfc_add_expr_to_block (&body, tmp); - - /* Null the reference the derived type so that this case is - not used again. */ - elist->derived = NULL; - } - - elist = tmp_elist; - - /* Get a pointer to the procedure, */ - tmp = gfc_get_symbol_decl (elist->esym); - if (!POINTER_TYPE_P (TREE_TYPE (tmp))) - { - gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL); - tmp = gfc_build_addr_expr (NULL_TREE, tmp); - } - - /* Assign the pointer to the appropriate procedure. */ - gfc_add_modify (&body, declared, - fold_convert (TREE_TYPE (declared), tmp)); - - /* Break to the end of the construct. */ - tmp = build1_v (GOTO_EXPR, end_label); - gfc_add_expr_to_block (&body, tmp); - - /* Free the elists as we go; freeing them in gfc_free_expr causes - segfaults because it occurs too early and too often. */ - free_elist: - next_elist = elist->next; - if (elist->hash_value) - gfc_free_expr (elist->hash_value); - gfc_free (elist); - elist = NULL; - } - - /* Default is an error. */ - label = gfc_build_label_decl (NULL_TREE); - tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, - NULL_TREE, NULL_TREE, label); - gfc_add_expr_to_block (&body, tmp); - tmp = gfc_trans_runtime_error (true, &expr->where, - "internal error: bad hash value in dynamic dispatch"); - gfc_add_expr_to_block (&body, tmp); - - /* Write the switch expression. */ - tmp = gfc_finish_block (&body); - tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE); - gfc_add_expr_to_block (&se->pre, tmp); - - tmp = build1_v (LABEL_EXPR, end_label); - gfc_add_expr_to_block (&se->pre, tmp); - - se->expr = declared; - return; -} - - static void conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr) { tree tmp; - if (expr && expr->symtree - && expr->value.function.class_esym) - { - if (!sym->backend_decl) - sym->backend_decl = gfc_get_extern_function_decl (sym); - - tmp = sym->backend_decl; - - if (!POINTER_TYPE_P (TREE_TYPE (tmp))) - { - gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL); - tmp = gfc_build_addr_expr (NULL_TREE, tmp); - } - - select_class_proc (se, expr->value.function.class_esym, - tmp, expr); - return; - } - if (gfc_is_proc_ptr_comp (expr, NULL)) tmp = get_proc_ptr_comp (expr); else if (sym->attr.dummy) @@ -1806,19 +1771,21 @@ gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc) } else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE) { - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, dim), - gfc_conv_descriptor_lbound_get (desc, dim)); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - GFC_TYPE_ARRAY_LBOUND (type, n), - tmp); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_conv_descriptor_ubound_get (desc, dim), + gfc_conv_descriptor_lbound_get (desc, dim)); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + GFC_TYPE_ARRAY_LBOUND (type, n), tmp); tmp = gfc_evaluate_now (tmp, block); GFC_TYPE_ARRAY_UBOUND (type, n) = tmp; } - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - GFC_TYPE_ARRAY_LBOUND (type, n), - GFC_TYPE_ARRAY_STRIDE (type, n)); - offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp); + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + GFC_TYPE_ARRAY_LBOUND (type, n), + GFC_TYPE_ARRAY_STRIDE (type, n)); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, offset, tmp); } offset = gfc_evaluate_now (offset, block); GFC_TYPE_ARRAY_OFFSET (type) = offset; @@ -1848,6 +1815,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, new_sym->as = gfc_copy_array_spec (sym->as); new_sym->attr.referenced = 1; new_sym->attr.dimension = sym->attr.dimension; + new_sym->attr.contiguous = sym->attr.contiguous; + new_sym->attr.codimension = sym->attr.codimension; new_sym->attr.pointer = sym->attr.pointer; new_sym->attr.allocatable = sym->attr.allocatable; new_sym->attr.flavor = sym->attr.flavor; @@ -1990,9 +1959,10 @@ gfc_finish_interface_mapping (gfc_interface_mapping * mapping, static void gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping, - gfc_constructor * c) + gfc_constructor_base base) { - for (; c; c = c->next) + gfc_constructor *c; + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { gfc_apply_interface_mapping_to_expr (mapping, c->expr); if (c->iterator) @@ -2076,7 +2046,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) break; case GFC_ISYM_SIZE: - if (!sym->as) + if (!sym->as || sym->as->rank == 0) return false; if (arg2 && arg2->expr_type == EXPR_CONSTANT) @@ -2100,7 +2070,9 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) return false; } - tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1)); + tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), + gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1)); tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d])); if (new_expr) new_expr = gfc_multiply (new_expr, tmp); @@ -2114,7 +2086,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) /* TODO These implementations of lbound and ubound do not limit if the size < 0, according to F95's 13.14.53 and 13.14.113. */ - if (!sym->as) + if (!sym->as || sym->as->rank == 0) return false; if (arg2 && arg2->expr_type == EXPR_CONSTANT) @@ -2451,26 +2423,30 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, { tree tmp_str; tmp = rse.loop->loopvar[n]; - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - tmp, rse.loop->from[n]); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - tmp, tmp_index); + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + tmp, rse.loop->from[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + tmp, tmp_index); - tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type, - rse.loop->to[n-1], rse.loop->from[n-1]); - tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type, - tmp_str, gfc_index_one_node); + tmp_str = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + rse.loop->to[n-1], rse.loop->from[n-1]); + tmp_str = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + tmp_str, gfc_index_one_node); - tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type, - tmp, tmp_str); + tmp_index = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, tmp_str); } - tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type, - tmp_index, rse.loop->from[0]); + tmp_index = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + tmp_index, rse.loop->from[0]); gfc_add_modify (&rse.loop->code[0], offset, tmp_index); - tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type, - rse.loop->loopvar[0], offset); + tmp_index = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + rse.loop->loopvar[0], offset); /* Now use the offset for the reference. */ tmp = build_fold_indirect_ref_loc (input_location, @@ -2518,8 +2494,9 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, { tmp = gfc_conv_descriptor_ubound_get (parmse->expr, gfc_rank_cst[n]); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); gfc_conv_descriptor_ubound_set (&parmse->pre, parmse->expr, gfc_rank_cst[n], @@ -2529,15 +2506,18 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, gfc_rank_cst[n], gfc_index_one_node); size = gfc_evaluate_now (size, &parmse->pre); - offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, - offset, size); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + offset, size); offset = gfc_evaluate_now (offset, &parmse->pre); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - rse.loop->to[n], rse.loop->from[n]); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, - size, tmp); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + rse.loop->to[n], rse.loop->from[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + tmp, gfc_index_one_node); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, tmp); } gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr, @@ -2599,11 +2579,12 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, /* Set the vptr. */ cmp = gfc_find_component (declared, "$vptr", true, true); - ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), - var, cmp->backend_decl, NULL_TREE); + ctree = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (cmp->backend_decl), + var, cmp->backend_decl, NULL_TREE); /* Remember the vtab corresponds to the derived type - not to the class declared type. */ + not to the class declared type. */ vtab = gfc_find_derived_vtab (e->ts.u.derived); gcc_assert (vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); @@ -2612,17 +2593,20 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, /* Now set the data field. */ cmp = gfc_find_component (declared, "$data", true, true); - ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), - var, cmp->backend_decl, NULL_TREE); + ctree = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (cmp->backend_decl), + var, cmp->backend_decl, NULL_TREE); ss = gfc_walk_expr (e); if (ss == gfc_ss_terminator) { + parmse->ss = NULL; gfc_conv_expr_reference (parmse, e); tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); gfc_add_modify (&parmse->pre, ctree, tmp); } else { + parmse->ss = ss; gfc_conv_expr (parmse, e); gfc_add_modify (&parmse->pre, ctree, parmse->expr); } @@ -2717,10 +2701,11 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, fptrse.expr = build_fold_indirect_ref_loc (input_location, fptrse.expr); - se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr), - fptrse.expr, - fold_convert (TREE_TYPE (fptrse.expr), - cptrse.expr)); + se->expr = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (fptrse.expr), + fptrse.expr, + fold_convert (TREE_TYPE (fptrse.expr), + cptrse.expr)); return 1; } @@ -2741,9 +2726,10 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, if (arg->next == NULL) /* Only given one arg so generate a null and do a not-equal comparison against the first arg. */ - se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr, - fold_convert (TREE_TYPE (arg1se.expr), - null_pointer_node)); + se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + arg1se.expr, + fold_convert (TREE_TYPE (arg1se.expr), + null_pointer_node)); else { tree eq_expr; @@ -2756,16 +2742,18 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, gfc_add_block_to_block (&se->post, &arg2se.post); /* Generate test to compare that the two args are equal. */ - eq_expr = fold_build2 (EQ_EXPR, boolean_type_node, - arg1se.expr, arg2se.expr); + eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + arg1se.expr, arg2se.expr); /* Generate test to ensure that the first arg is not null. */ - not_null_expr = fold_build2 (NE_EXPR, boolean_type_node, - arg1se.expr, null_pointer_node); + not_null_expr = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + arg1se.expr, null_pointer_node); /* Finally, the generated test must check that both arg1 is not NULL and that it is equal to the second arg. */ - se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - not_null_expr, eq_expr); + se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, + not_null_expr, eq_expr); } return 1; @@ -2775,7 +2763,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. @@ -2784,11 +2771,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; @@ -2799,7 +2786,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; @@ -2812,10 +2799,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); @@ -2899,6 +2887,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, parmse.string_length = build_int_cst (gfc_charlen_type_node, 0); } } + else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer) + { + /* Pass a NULL pointer to denote an absent arg. */ + gcc_assert (fsym->attr.optional && !fsym->attr.allocatable); + gfc_init_se (&parmse, NULL); + parmse.expr = null_pointer_node; + if (arg->missing_arg_type == BT_CHARACTER) + parmse.string_length = build_int_cst (gfc_charlen_type_node, 0); + } else if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_DERIVED) { @@ -2987,15 +2984,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE, true, NULL); gfc_add_expr_to_block (&block, tmp); - tmp = fold_build2 (MODIFY_EXPR, void_type_node, - parmse.expr, null_pointer_node); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, parmse.expr, + null_pointer_node); gfc_add_expr_to_block (&block, tmp); if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) { - tmp = fold_build3 (COND_EXPR, void_type_node, + tmp = fold_build3_loc (input_location, COND_EXPR, + void_type_node, gfc_conv_expr_present (e->symtree->n.sym), gfc_finish_block (&block), build_empty_stmt (input_location)); @@ -3035,7 +3034,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, bool f; f = (fsym != NULL) && !(fsym->attr.pointer || fsym->attr.allocatable) - && fsym->as->type != AS_ASSUMED_SHAPE; + && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE; if (comp) f = f || !comp->attr.always_explicit; else @@ -3065,7 +3064,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) - tmp = fold_build3 (COND_EXPR, void_type_node, + tmp = fold_build3_loc (input_location, COND_EXPR, + void_type_node, gfc_conv_expr_present (e->symtree->n.sym), tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->pre, tmp); @@ -3196,7 +3196,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, it is invalid to pass a non-present argument on, even though there is no technical reason for this in gfortran. See Fortran 2003, Section 12.4.1.6 item (7)+(8). */ - tree present, nullptr, type; + tree present, null_ptr, type; if (attr->allocatable && (fsym == NULL || !fsym->attr.allocatable)) @@ -3217,13 +3217,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, present = gfc_conv_expr_present (e->symtree->n.sym); type = TREE_TYPE (present); - present = fold_build2 (EQ_EXPR, boolean_type_node, present, - fold_convert (type, null_pointer_node)); + present = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, present, + fold_convert (type, + null_pointer_node)); type = TREE_TYPE (parmse.expr); - nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr, - fold_convert (type, null_pointer_node)); - cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, - present, nullptr); + null_ptr = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, parmse.expr, + fold_convert (type, + null_pointer_node)); + cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + boolean_type_node, present, null_ptr); } else { @@ -3243,9 +3247,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, goto end_pointer_check; - cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr, - fold_convert (TREE_TYPE (parmse.expr), - null_pointer_node)); + cond = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, parmse.expr, + fold_convert (TREE_TYPE (parmse.expr), + null_pointer_node)); } gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where, @@ -3258,9 +3263,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); @@ -3282,7 +3287,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; @@ -3305,8 +3310,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_add_block_to_block (&se->post, &parmse.post); tmp = fold_convert (gfc_charlen_type_node, parmse.expr); - tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp, - build_int_cst (gfc_charlen_type_node, 0)); + tmp = fold_build2_loc (input_location, MAX_EXPR, + gfc_charlen_type_node, tmp, + build_int_cst (gfc_charlen_type_node, 0)); cl.backend_decl = tmp; } @@ -3335,7 +3341,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) { @@ -3359,7 +3365,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) { @@ -3383,7 +3389,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) { @@ -3410,7 +3416,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 { @@ -3418,25 +3424,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); @@ -3460,7 +3472,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 @@ -3504,8 +3516,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Check the data pointer hasn't been modified. This would happen in a function returning a pointer. */ tmp = gfc_conv_descriptor_data_get (info->descriptor); - tmp = fold_build2 (NE_EXPR, boolean_type_node, - tmp, info->data); + tmp = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + tmp, info->data); gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL, gfc_msg_fault); } @@ -3606,24 +3619,25 @@ fill_with_spaces (tree start, tree type, tree size) gfc_init_block (&loop); /* Exit condition. */ - cond = fold_build2 (LE_EXPR, boolean_type_node, i, - fold_convert (sizetype, integer_zero_node)); + cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i, + fold_convert (sizetype, integer_zero_node)); tmp = build1_v (GOTO_EXPR, exit_label); - tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, - build_empty_stmt (input_location)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, + build_empty_stmt (input_location)); gfc_add_expr_to_block (&loop, tmp); /* Assignment. */ - gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el), - build_int_cst (type, - lang_hooks.to_target_charset (' '))); + gfc_add_modify (&loop, + fold_build1_loc (input_location, INDIRECT_REF, type, el), + build_int_cst (type, lang_hooks.to_target_charset (' '))); /* Increment loop variables. */ - gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i, - TYPE_SIZE_UNIT (type))); - gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR, - TREE_TYPE (el), el, - TYPE_SIZE_UNIT (type))); + gfc_add_modify (&loop, i, + fold_build2_loc (input_location, MINUS_EXPR, sizetype, i, + TYPE_SIZE_UNIT (type))); + gfc_add_modify (&loop, el, + fold_build2_loc (input_location, POINTER_PLUS_EXPR, + TREE_TYPE (el), el, TYPE_SIZE_UNIT (type))); /* Making the loop... actually loop! */ tmp = gfc_finish_block (&loop); @@ -3661,7 +3675,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 { @@ -3672,7 +3686,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 { @@ -3680,12 +3694,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)) @@ -3695,8 +3703,8 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, } /* Do nothing if the destination length is zero. */ - cond = fold_build2 (GT_EXPR, boolean_type_node, dlen, - build_int_cst (size_type_node, 0)); + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen, + build_int_cst (size_type_node, 0)); /* The following code was previously in _gfortran_copy_string: @@ -3724,12 +3732,14 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, /* For non-default character kinds, we have to multiply the string length by the base type size. */ chartype = gfc_get_char_type (dkind); - slen = fold_build2 (MULT_EXPR, size_type_node, - fold_convert (size_type_node, slen), - fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype))); - dlen = fold_build2 (MULT_EXPR, size_type_node, - fold_convert (size_type_node, dlen), - fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype))); + slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + fold_convert (size_type_node, slen), + fold_convert (size_type_node, + TYPE_SIZE_UNIT (chartype))); + dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + fold_convert (size_type_node, dlen), + fold_convert (size_type_node, + TYPE_SIZE_UNIT (chartype))); if (dlength) dest = fold_convert (pvoid_type_node, dest); @@ -3742,7 +3752,8 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, src = gfc_build_addr_expr (pvoid_type_node, src); /* Truncate string if source is too long. */ - cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen); + cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen, + dlen); tmp2 = build_call_expr_loc (input_location, built_in_decls[BUILT_IN_MEMMOVE], 3, dest, src, dlen); @@ -3752,11 +3763,11 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, built_in_decls[BUILT_IN_MEMMOVE], 3, dest, src, slen); - tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest, - fold_convert (sizetype, slen)); + tmp4 = fold_build2_loc (input_location, POINTER_PLUS_EXPR, TREE_TYPE (dest), + dest, fold_convert (sizetype, slen)); tmp4 = fill_with_spaces (tmp4, chartype, - fold_build2 (MINUS_EXPR, TREE_TYPE(dlen), - dlen, slen)); + fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE(dlen), dlen, slen)); gfc_init_block (&tempblock); gfc_add_expr_to_block (&tempblock, tmp3); @@ -3764,9 +3775,10 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, tmp3 = gfc_finish_block (&tempblock); /* The whole copy_string function is there. */ - tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3); - tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, - build_empty_stmt (input_location)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, + tmp2, tmp3); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, + build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); } @@ -3908,8 +3920,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); } @@ -3967,11 +3978,11 @@ gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr) tree gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, - bool array, bool pointer) + bool array, bool pointer, bool procptr) { gfc_se se; - if (!(expr || pointer)) + if (!(expr || pointer || procptr)) return NULL_TREE; /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR @@ -3983,31 +3994,44 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, { gfc_symbol *derived = expr->ts.u.derived; - expr = gfc_int_expr (0); - /* The derived symbol has already been converted to a (void *). Use its kind. */ + expr = gfc_get_int_expr (derived->ts.kind, NULL, 0); expr->ts.f90_type = derived->ts.f90_type; - expr->ts.kind = derived->ts.kind; gfc_init_se (&se, NULL); gfc_conv_constant (&se, expr); + gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR); return se.expr; } - if (array) + if (array && !procptr) { + tree ctor; /* Arrays need special handling. */ if (pointer) - return gfc_build_null_descriptor (type); + ctor = gfc_build_null_descriptor (type); /* Special case assigning an array to zero. */ else if (is_zero_initializer_p (expr)) - return build_constructor (type, NULL); + ctor = build_constructor (type, NULL); else - return gfc_conv_array_initializer (type, expr); + ctor = gfc_conv_array_initializer (type, expr); + TREE_STATIC (ctor) = 1; + return ctor; + } + else if (pointer || procptr) + { + if (!expr || expr->expr_type == EXPR_NULL) + return fold_convert (type, null_pointer_node); + else + { + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, expr); + gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR); + return se.expr; + } } - else if (pointer) - return fold_convert (type, null_pointer_node); else { switch (ts->type) @@ -4015,15 +4039,25 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, case BT_DERIVED: case BT_CLASS: gfc_init_se (&se, NULL); - gfc_conv_structure (&se, expr, 1); + if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL) + gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1); + else + gfc_conv_structure (&se, expr, 1); + gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR); + TREE_STATIC (se.expr) = 1; return se.expr; case BT_CHARACTER: - return gfc_conv_string_init (ts->u.cl->backend_decl,expr); + { + tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr); + TREE_STATIC (ctor) = 1; + return ctor; + } default: gfc_init_se (&se, NULL); gfc_conv_constant (&se, expr); + gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR); return se.expr; } } @@ -4230,21 +4264,23 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, /* Shift the bounds and set the offset accordingly. */ tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]); - span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp, - gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n])); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, span, lbound); + span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n])); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + span, lbound); gfc_conv_descriptor_ubound_set (&block, dest, gfc_rank_cst[n], tmp); gfc_conv_descriptor_lbound_set (&block, dest, gfc_rank_cst[n], lbound); - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]), gfc_conv_descriptor_stride_get (dest, gfc_rank_cst[n])); gfc_add_modify (&block, tmp2, tmp); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2); + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + offset, tmp2); gfc_conv_descriptor_offset_set (&block, dest, tmp); } @@ -4264,9 +4300,8 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, null_pointer_node); null_expr = gfc_finish_block (&block); tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl); - tmp = build2 (EQ_EXPR, boolean_type_node, tmp, - fold_convert (TREE_TYPE (tmp), - null_pointer_node)); + tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp, + fold_convert (TREE_TYPE (tmp), null_pointer_node)); return build3_v (COND_EXPR, tmp, null_expr, non_null_expr); } @@ -4323,7 +4358,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) { /* NULL initialization for CLASS components. */ tmp = gfc_trans_structure_assign (dest, - gfc_default_initializer (&cm->ts)); + gfc_class_null_initializer (&cm->ts)); gfc_add_expr_to_block (&block, tmp); } else if (cm->attr.dimension) @@ -4388,7 +4423,8 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr) gfc_start_block (&block); cm = expr->ts.u.derived->components; - for (c = expr->value.constructor; c; c = c->next, cm = cm->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c), cm = cm->next) { /* Skip absent members in default initializers. */ if (!c->expr) @@ -4398,18 +4434,19 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr) if (c && c->expr && c->expr->ts.is_iso_c) { field = cm->backend_decl; - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), - dest, field, NULL_TREE); - tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp, - fold_convert (TREE_TYPE (tmp), - null_pointer_node)); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), + dest, field, NULL_TREE); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), + tmp, fold_convert (TREE_TYPE (tmp), + null_pointer_node)); gfc_add_expr_to_block (&block, tmp); continue; } field = cm->backend_decl; - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), - dest, field, NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + dest, field, NULL_TREE); tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr); gfc_add_expr_to_block (&block, tmp); } @@ -4444,7 +4481,8 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) cm = expr->ts.u.derived->components; - for (c = expr->value.constructor; c; c = c->next, cm = cm->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c), cm = cm->next) { /* Skip absent members in default initializers and allocatable components. Although the latter have a default initializer @@ -4453,20 +4491,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) if (!c->expr || cm->attr.allocatable) continue; - if (cm->ts.type == BT_CLASS) - { - gfc_component *data; - data = gfc_find_component (cm->ts.u.derived, "$data", true, true); - if (!data->backend_decl) - gfc_get_derived_type (cm->ts.u.derived); - val = gfc_conv_initializer (c->expr, &cm->ts, - TREE_TYPE (data->backend_decl), - data->attr.dimension, - data->attr.pointer); - - CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val); - } - else if (strcmp (cm->name, "$size") == 0) + if (strcmp (cm->name, "$size") == 0) { val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived)); CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); @@ -4474,16 +4499,18 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL && strcmp (cm->name, "$extends") == 0) { + tree vtab; gfc_symbol *vtabs; vtabs = cm->initializer->symtree->n.sym; - val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs)); - CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs)); + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab); } else { val = gfc_conv_initializer (c->expr, &cm->ts, - TREE_TYPE (cm->backend_decl), cm->attr.dimension, - cm->attr.pointer || cm->attr.proc_pointer); + TREE_TYPE (cm->backend_decl), + cm->attr.dimension, cm->attr.pointer, + cm->attr.proc_pointer); /* Append it to the constructor list. */ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); @@ -4531,6 +4558,8 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr) /* Substitute a scalar expression evaluated outside the scalarization loop. */ se->expr = se->ss->data.scalar.expr; + if (se->ss->type == GFC_SS_REFERENCE) + se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); se->string_length = se->ss->string_length; gfc_advance_se_ss_chain (se); return; @@ -4651,9 +4680,9 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) if (se->ss && se->ss->expr == expr && se->ss->type == GFC_SS_REFERENCE) { - se->expr = se->ss->data.scalar.expr; - se->string_length = se->ss->string_length; - gfc_advance_se_ss_chain (se); + /* Returns a reference to the scalar evaluated outside the loop + for this case. */ + gfc_conv_expr (se, expr); return; } @@ -4791,21 +4820,46 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) } else { + gfc_ref* remap; + bool rank_remap; tree strlen_lhs; tree strlen_rhs = NULL_TREE; - /* Array pointer. */ + /* Array pointer. Find the last reference on the LHS and if it is an + array section ref, we're dealing with bounds remapping. In this case, + set it to AR_FULL so that gfc_conv_expr_descriptor does + not see it and process the bounds remapping afterwards explicitely. */ + for (remap = expr1->ref; remap; remap = remap->next) + if (!remap->next && remap->type == REF_ARRAY + && remap->u.ar.type == AR_SECTION) + { + remap->u.ar.type = AR_FULL; + break; + } + rank_remap = (remap && remap->u.ar.end[0]); + gfc_conv_expr_descriptor (&lse, expr1, lss); strlen_lhs = lse.string_length; - switch (expr2->expr_type) + desc = lse.expr; + + if (expr2->expr_type == EXPR_NULL) { - case EXPR_NULL: /* Just set the data pointer to null. */ gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node); - break; - - case EXPR_VARIABLE: - /* Assign directly to the pointer's descriptor. */ + } + else if (rank_remap) + { + /* If we are rank-remapping, just get the RHS's descriptor and + process this later on. */ + gfc_init_se (&rse, NULL); + rse.direct_byref = 1; + rse.byref_noassign = 1; + gfc_conv_expr_descriptor (&rse, expr2, rss); + strlen_rhs = rse.string_length; + } + else if (expr2->expr_type == EXPR_VARIABLE) + { + /* Assign directly to the LHS's descriptor. */ lse.direct_byref = 1; gfc_conv_expr_descriptor (&lse, expr2, rss); strlen_rhs = lse.string_length; @@ -4824,13 +4878,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_add_block_to_block (&lse.post, &rse.pre); gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp); } - - break; - - default: + } + else + { /* Assign to a temporary descriptor and then copy that temporary to the pointer. */ - desc = lse.expr; tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp"); lse.expr = tmp; @@ -4838,10 +4890,130 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_conv_expr_descriptor (&lse, expr2, rss); strlen_rhs = lse.string_length; gfc_add_modify (&lse.pre, desc, tmp); - break; } gfc_add_block_to_block (&block, &lse.pre); + if (rank_remap) + gfc_add_block_to_block (&block, &rse.pre); + + /* If we do bounds remapping, update LHS descriptor accordingly. */ + if (remap) + { + int dim; + gcc_assert (remap->u.ar.dimen == expr1->rank); + + if (rank_remap) + { + /* Do rank remapping. We already have the RHS's descriptor + converted in rse and now have to build the correct LHS + descriptor for it. */ + + tree dtype, data; + tree offs, stride; + tree lbound, ubound; + + /* Set dtype. */ + dtype = gfc_conv_descriptor_dtype (desc); + tmp = gfc_get_dtype (TREE_TYPE (desc)); + gfc_add_modify (&block, dtype, tmp); + + /* Copy data pointer. */ + data = gfc_conv_descriptor_data_get (rse.expr); + gfc_conv_descriptor_data_set (&block, desc, data); + + /* Copy offset but adjust it such that it would correspond + to a lbound of zero. */ + offs = gfc_conv_descriptor_offset_get (rse.expr); + for (dim = 0; dim < expr2->rank; ++dim) + { + stride = gfc_conv_descriptor_stride_get (rse.expr, + gfc_rank_cst[dim]); + lbound = gfc_conv_descriptor_lbound_get (rse.expr, + gfc_rank_cst[dim]); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, stride, lbound); + offs = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, offs, tmp); + } + gfc_conv_descriptor_offset_set (&block, desc, offs); + + /* Set the bounds as declared for the LHS and calculate strides as + well as another offset update accordingly. */ + stride = gfc_conv_descriptor_stride_get (rse.expr, + gfc_rank_cst[0]); + for (dim = 0; dim < expr1->rank; ++dim) + { + gfc_se lower_se; + gfc_se upper_se; + + gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]); + + /* Convert declared bounds. */ + gfc_init_se (&lower_se, NULL); + gfc_init_se (&upper_se, NULL); + gfc_conv_expr (&lower_se, remap->u.ar.start[dim]); + gfc_conv_expr (&upper_se, remap->u.ar.end[dim]); + + gfc_add_block_to_block (&block, &lower_se.pre); + gfc_add_block_to_block (&block, &upper_se.pre); + + lbound = fold_convert (gfc_array_index_type, lower_se.expr); + ubound = fold_convert (gfc_array_index_type, upper_se.expr); + + lbound = gfc_evaluate_now (lbound, &block); + ubound = gfc_evaluate_now (ubound, &block); + + gfc_add_block_to_block (&block, &lower_se.post); + gfc_add_block_to_block (&block, &upper_se.post); + + /* Set bounds in descriptor. */ + gfc_conv_descriptor_lbound_set (&block, desc, + gfc_rank_cst[dim], lbound); + gfc_conv_descriptor_ubound_set (&block, desc, + gfc_rank_cst[dim], ubound); + + /* Set stride. */ + stride = gfc_evaluate_now (stride, &block); + gfc_conv_descriptor_stride_set (&block, desc, + gfc_rank_cst[dim], stride); + + /* Update offset. */ + offs = gfc_conv_descriptor_offset_get (desc); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, lbound, stride); + offs = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, offs, tmp); + offs = gfc_evaluate_now (offs, &block); + gfc_conv_descriptor_offset_set (&block, desc, offs); + + /* Update stride. */ + tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL); + stride = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, stride, tmp); + } + } + else + { + /* Bounds remapping. Just shift the lower bounds. */ + + gcc_assert (expr1->rank == expr2->rank); + + for (dim = 0; dim < remap->u.ar.dimen; ++dim) + { + gfc_se lbound_se; + + gcc_assert (remap->u.ar.start[dim]); + gcc_assert (!remap->u.ar.end[dim]); + gfc_init_se (&lbound_se, NULL); + gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]); + + gfc_add_block_to_block (&block, &lbound_se.pre); + gfc_conv_shift_descriptor_lbound (&block, desc, + dim, lbound_se.expr); + gfc_add_block_to_block (&block, &lbound_se.post); + } + } + } /* Check string lengths if applicable. The check is only really added to the output code if -fbounds-check is enabled. */ @@ -4853,8 +5025,32 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) strlen_lhs, strlen_rhs, &block); } + /* If rank remapping was done, check with -fcheck=bounds that + the target is at least as large as the pointer. */ + if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) + { + tree lsize, rsize; + tree fault; + const char* msg; + + lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank); + rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank); + + lsize = gfc_evaluate_now (lsize, &block); + rsize = gfc_evaluate_now (rsize, &block); + fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + rsize, lsize); + + msg = _("Target of rank remapping is too small (%ld < %ld)"); + gfc_trans_runtime_check (true, false, fault, &block, &expr2->where, + msg, rsize, lsize); + } + gfc_add_block_to_block (&block, &lse.post); + if (rank_remap) + gfc_add_block_to_block (&block, &rse.post); } + return gfc_finish_block (&block); } @@ -4940,9 +5136,9 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, /* Are the rhs and the lhs the same? */ if (r_is_var) { - cond = fold_build2 (EQ_EXPR, boolean_type_node, - gfc_build_addr_expr (NULL_TREE, lse->expr), - gfc_build_addr_expr (NULL_TREE, rse->expr)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + gfc_build_addr_expr (NULL_TREE, lse->expr), + gfc_build_addr_expr (NULL_TREE, rse->expr)); cond = gfc_evaluate_now (cond, &lse->pre); } @@ -4980,7 +5176,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, { gfc_add_block_to_block (&block, &lse->pre); gfc_add_block_to_block (&block, &rse->pre); - tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr); + tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + TREE_TYPE (lse->expr), rse->expr); gfc_add_modify (&block, lse->expr, tmp); } else @@ -4999,41 +5196,40 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, } -/* Try to translate array(:) = func (...), where func is a transformational - array function, without using a temporary. Returns NULL is this isn't the - case. */ +/* There are quite a lot of restrictions on the optimisation in using an + array function assign without a temporary. */ -static tree -gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) +static bool +arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2) { - gfc_se se; - gfc_ss *ss; gfc_ref * ref; bool seen_array_ref; bool c = false; - gfc_component *comp = NULL; + gfc_symbol *sym = expr1->symtree->n.sym; /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */ if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2)) - return NULL; + return true; - /* Elemental functions don't need a temporary anyway. */ + /* Elemental functions are scalarized so that they don't need a + temporary in gfc_trans_assignment_1, so return a true. Otherwise, + they would need special treatment in gfc_trans_arrayfunc_assign. */ if (expr2->value.function.esym != NULL && expr2->value.function.esym->attr.elemental) - return NULL; + return true; - /* Fail if rhs is not FULL or a contiguous section. */ + /* Need a temporary if rhs is not FULL or a contiguous section. */ if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c)) - return NULL; + return true; - /* Fail if EXPR1 can't be expressed as a descriptor. */ + /* Need a temporary if EXPR1 can't be expressed as a descriptor. */ if (gfc_ref_needs_temporary_p (expr1->ref)) - return NULL; + return true; /* Functions returning pointers need temporaries. */ if (expr2->symtree->n.sym->attr.pointer || expr2->symtree->n.sym->attr.allocatable) - return NULL; + return true; /* Character array functions need temporaries unless the character lengths are the same. */ @@ -5041,15 +5237,15 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) { if (expr1->ts.u.cl->length == NULL || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT) - return NULL; + return true; if (expr2->ts.u.cl->length == NULL || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT) - return NULL; + return true; if (mpz_cmp (expr1->ts.u.cl->length->value.integer, expr2->ts.u.cl->length->value.integer) != 0) - return NULL; + return true; } /* Check that no LHS component references appear during an array @@ -5063,7 +5259,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) if (ref->type == REF_ARRAY) seen_array_ref= true; else if (ref->type == REF_COMPONENT && seen_array_ref) - return NULL; + return true; } /* Check for a dependency. */ @@ -5071,6 +5267,67 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) expr2->value.function.esym, expr2->value.function.actual, NOT_ELEMENTAL)) + return true; + + /* If we have reached here with an intrinsic function, we do not + need a temporary. */ + if (expr2->value.function.isym) + return false; + + /* If the LHS is a dummy, we need a temporary if it is not + INTENT(OUT). */ + if (sym->attr.dummy && sym->attr.intent != INTENT_OUT) + return true; + + /* A PURE function can unconditionally be called without a temporary. */ + if (expr2->value.function.esym != NULL + && expr2->value.function.esym->attr.pure) + return false; + + /* TODO a function that could correctly be declared PURE but is not + could do with returning false as well. */ + + if (!sym->attr.use_assoc + && !sym->attr.in_common + && !sym->attr.pointer + && !sym->attr.target + && expr2->value.function.esym) + { + /* A temporary is not needed if the function is not contained and + the variable is local or host associated and not a pointer or + a target. */ + if (!expr2->value.function.esym->attr.contained) + return false; + + /* A temporary is not needed if the 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 + && expr2->value.function.esym->ns == sym->ns->parent) + return false; + } + + /* Default to temporary use. */ + return true; +} + + +/* Try to translate array(:) = func (...), where func is a transformational + array function, without using a temporary. Returns NULL if this isn't the + case. */ + +static tree +gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) +{ + gfc_se se; + gfc_ss *ss; + gfc_component *comp = NULL; + + if (arrayfunc_assign_needs_temporary (expr1, expr2)) return NULL; /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic @@ -5133,14 +5390,14 @@ gfc_trans_zero_assign (gfc_expr * expr) return NULL_TREE; tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - len = fold_build2 (MULT_EXPR, gfc_array_index_type, len, - fold_convert (gfc_array_index_type, tmp)); + len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len, + fold_convert (gfc_array_index_type, tmp)); /* If we are zeroing a local array avoid taking its address by emitting a = {} instead. */ if (!POINTER_TYPE_P (TREE_TYPE (dest))) - return build2 (MODIFY_EXPR, void_type_node, - dest, build_constructor (TREE_TYPE (dest), NULL)); + return build2_loc (input_location, MODIFY_EXPR, void_type_node, + dest, build_constructor (TREE_TYPE (dest), NULL)); /* Convert arguments to the correct types. */ dest = fold_convert (pvoid_type_node, dest); @@ -5212,15 +5469,15 @@ gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2) if (!dlen || TREE_CODE (dlen) != INTEGER_CST) return NULL_TREE; tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype)); - dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen, - fold_convert (gfc_array_index_type, tmp)); + dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + dlen, fold_convert (gfc_array_index_type, tmp)); slen = GFC_TYPE_ARRAY_SIZE (stype); if (!slen || TREE_CODE (slen) != INTEGER_CST) return NULL_TREE; tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype)); - slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen, - fold_convert (gfc_array_index_type, tmp)); + slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + slen, fold_convert (gfc_array_index_type, tmp)); /* Sanity check that they are the same. This should always be the case, as we should already have checked for conformance. */ @@ -5265,8 +5522,8 @@ gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2) return NULL_TREE; tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype)); - len = fold_build2 (MULT_EXPR, gfc_array_index_type, len, - fold_convert (gfc_array_index_type, tmp)); + len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len, + fold_convert (gfc_array_index_type, tmp)); stype = gfc_typenode_for_spec (&expr2->ts); src = gfc_build_constant_array_constructor (expr2, stype); @@ -5279,6 +5536,27 @@ gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2) } +/* Tells whether the expression is to be treated as a variable reference. */ + +static bool +expr_is_variable (gfc_expr *expr) +{ + gfc_expr *arg; + + if (expr->expr_type == EXPR_VARIABLE) + return true; + + arg = gfc_get_noncopying_intrinsic_argument (expr); + if (arg) + { + gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE); + return expr_is_variable (arg); + } + + return false; +} + + /* Subroutine of gfc_trans_assignment that actually scalarizes the assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. init_flag indicates initialization expressions and dealloc that no @@ -5300,6 +5578,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); @@ -5345,6 +5624,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. */ @@ -5400,7 +5682,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, must have its components deallocated afterwards. */ scalar_to_array = (expr2->ts.type == BT_DERIVED && expr2->ts.u.derived->attr.alloc_comp - && expr2->expr_type != EXPR_VARIABLE + && !expr_is_variable (expr2) && !gfc_is_constant_expr (expr2) && expr1->rank && !expr2->rank); if (scalar_to_array && dealloc) @@ -5411,8 +5693,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, l_is_temp || init_flag, - (expr2->expr_type == EXPR_VARIABLE) - || scalar_to_array, dealloc); + expr_is_variable (expr2) || scalar_to_array, + dealloc); gfc_add_expr_to_block (&body, tmp); if (lss == gfc_ss_terminator) @@ -5567,11 +5849,50 @@ gfc_trans_assign (gfc_code * code) } +/* Special case for initializing a polymorphic dummy with INTENT(OUT). + A MEMCPY is needed to copy the full data from the default initializer + of the dynamic type. */ + +tree +gfc_trans_class_init_assign (gfc_code *code) +{ + stmtblock_t block; + tree tmp; + gfc_se dst,src,memsz; + gfc_expr *lhs,*rhs,*sz; + + gfc_start_block (&block); + + lhs = gfc_copy_expr (code->expr1); + gfc_add_component_ref (lhs, "$data"); + + rhs = gfc_copy_expr (code->expr1); + gfc_add_component_ref (rhs, "$vptr"); + gfc_add_component_ref (rhs, "$def_init"); + + sz = gfc_copy_expr (code->expr1); + gfc_add_component_ref (sz, "$vptr"); + gfc_add_component_ref (sz, "$size"); + + gfc_init_se (&dst, NULL); + gfc_init_se (&src, NULL); + gfc_init_se (&memsz, NULL); + gfc_conv_expr (&dst, lhs); + gfc_conv_expr (&src, rhs); + gfc_conv_expr (&memsz, sz); + gfc_add_block_to_block (&block, &src.pre); + tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + /* Translate an assignment to a CLASS object (pointer or ordinary assignment). */ tree -gfc_trans_class_assign (gfc_code *code) +gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) { stmtblock_t block; tree tmp; @@ -5579,46 +5900,26 @@ gfc_trans_class_assign (gfc_code *code) gfc_expr *rhs; gfc_start_block (&block); - - if (code->op == EXEC_INIT_ASSIGN) - { - /* Special case for initializing a CLASS variable on allocation. - A MEMCPY is needed to copy the full data of the dynamic type, - which may be different from the declared type. */ - gfc_se dst,src; - tree memsz; - gfc_init_se (&dst, NULL); - gfc_init_se (&src, NULL); - gfc_add_component_ref (code->expr1, "$data"); - gfc_conv_expr (&dst, code->expr1); - gfc_conv_expr (&src, code->expr2); - gfc_add_block_to_block (&block, &src.pre); - memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts)); - tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz); - gfc_add_expr_to_block (&block, tmp); - return gfc_finish_block (&block); - } - if (code->expr2->ts.type != BT_CLASS) + if (expr2->ts.type != BT_CLASS) { /* Insert an additional assignment which sets the '$vptr' field. */ - lhs = gfc_copy_expr (code->expr1); + lhs = gfc_copy_expr (expr1); gfc_add_component_ref (lhs, "$vptr"); - if (code->expr2->ts.type == BT_DERIVED) + if (expr2->ts.type == BT_DERIVED) { gfc_symbol *vtab; gfc_symtree *st; - vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived); + vtab = gfc_find_derived_vtab (expr2->ts.u.derived); gcc_assert (vtab); - rhs = gfc_get_expr (); rhs->expr_type = EXPR_VARIABLE; gfc_find_sym_tree (vtab->name, NULL, 1, &st); rhs->symtree = st; rhs->ts = vtab->ts; } - else if (code->expr2->expr_type == EXPR_NULL) - rhs = gfc_int_expr (0); + else if (expr2->expr_type == EXPR_NULL) + rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); else gcc_unreachable (); @@ -5630,15 +5931,15 @@ gfc_trans_class_assign (gfc_code *code) } /* Do the actual CLASS assignment. */ - if (code->expr2->ts.type == BT_CLASS) - code->op = EXEC_ASSIGN; + if (expr2->ts.type == BT_CLASS) + op = EXEC_ASSIGN; else - gfc_add_component_ref (code->expr1, "$data"); + gfc_add_component_ref (expr1, "$data"); - if (code->op == EXEC_ASSIGN) - tmp = gfc_trans_assign (code); - else if (code->op == EXEC_POINTER_ASSIGN) - tmp = gfc_trans_pointer_assign (code); + if (op == EXEC_ASSIGN) + tmp = gfc_trans_assignment (expr1, expr2, false, true); + else if (op == EXEC_POINTER_ASSIGN) + tmp = gfc_trans_pointer_assignment (expr1, expr2); else gcc_unreachable(); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 95a8af47463..6e9bfaf8b36 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -25,12 +25,11 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "tm.h" +#include "tm.h" /* For UNITS_PER_WORD. */ #include "tree.h" #include "ggc.h" -#include "toplev.h" -#include "real.h" -#include "gimple.h" +#include "diagnostic-core.h" /* For internal_error. */ +#include "toplev.h" /* For rest_of_decl_compilation. */ #include "flags.h" #include "gfortran.h" #include "arith.h" @@ -52,14 +51,12 @@ typedef struct GTY(()) gfc_intrinsic_map_t { /* Enum value from the "language-independent", aka C-centric, part of gcc, or END_BUILTINS of no such value set. */ - enum built_in_function code_r4; - enum built_in_function code_r8; - enum built_in_function code_r10; - enum built_in_function code_r16; - enum built_in_function code_c4; - enum built_in_function code_c8; - enum built_in_function code_c10; - enum built_in_function code_c16; + enum built_in_function float_built_in; + enum built_in_function double_built_in; + enum built_in_function long_double_built_in; + enum built_in_function complex_float_built_in; + enum built_in_function complex_double_built_in; + enum built_in_function complex_long_double_built_in; /* True if the naming pattern is to prepend "c" for complex and append "f" for kind=4. False if the naming pattern is to @@ -92,28 +89,33 @@ gfc_intrinsic_map_t; except for atan2. */ #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \ { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ - BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, (enum built_in_function) 0, \ - (enum built_in_function) 0, (enum built_in_function) 0, \ - (enum built_in_function) 0, true, false, true, NAME, NULL_TREE, \ - NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ - NULL_TREE}, + BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ + true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ + NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \ { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ - BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \ - BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \ - true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ - NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, + BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \ + BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \ + NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \ - { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ - END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ + { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ + END_BUILTINS, END_BUILTINS, END_BUILTINS, \ false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \ NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE } +#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \ + { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ + BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ + true, false, CONST, NAME, NULL_TREE, NULL_TREE, \ + NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, + static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] = { - /* Functions built into gcc itself. */ + /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and + DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond + to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */ #include "mathbuiltins.def" /* Functions in libgfortran. */ @@ -123,30 +125,64 @@ static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] = LIB_FUNCTION (NONE, NULL, false) }; +#undef OTHER_BUILTIN #undef LIB_FUNCTION #undef DEFINE_MATH_BUILTIN #undef DEFINE_MATH_BUILTIN_C -/* Structure for storing components of a floating number to be used by - elemental functions to manipulate reals. */ -typedef struct + +enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR }; + + +/* Find the correct variant of a given builtin from its argument. */ +static tree +builtin_decl_for_precision (enum built_in_function base_built_in, + int precision) { - tree arg; /* Variable tree to view convert to integer. */ - tree expn; /* Variable tree to save exponent. */ - tree frac; /* Variable tree to save fraction. */ - tree smask; /* Constant tree of sign's mask. */ - tree emask; /* Constant tree of exponent's mask. */ - tree fmask; /* Constant tree of fraction's mask. */ - tree edigits; /* Constant tree of the number of exponent bits. */ - tree fdigits; /* Constant tree of the number of fraction bits. */ - tree f1; /* Constant tree of the f1 defined in the real model. */ - tree bias; /* Constant tree of the bias of exponent in the memory. */ - tree type; /* Type tree of arg1. */ - tree mtype; /* Type tree of integer type. Kind is that of arg1. */ + int i = END_BUILTINS; + + gfc_intrinsic_map_t *m; + for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++) + ; + + if (precision == TYPE_PRECISION (float_type_node)) + i = m->float_built_in; + else if (precision == TYPE_PRECISION (double_type_node)) + i = m->double_built_in; + else if (precision == TYPE_PRECISION (long_double_type_node)) + i = m->long_double_built_in; + else if (precision == TYPE_PRECISION (float128_type_node)) + { + /* Special treatment, because it is not exactly a built-in, but + a library function. */ + return m->real16_decl; + } + + return (i == END_BUILTINS ? NULL_TREE : built_in_decls[i]); +} + + +tree +gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in, + int kind) +{ + int i = gfc_validate_kind (BT_REAL, kind, false); + + if (gfc_real_kinds[i].c_float128) + { + /* For __float128, the story is a bit different, because we return + a decl to a library function rather than a built-in. */ + gfc_intrinsic_map_t *m; + for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++) + ; + + return m->real16_decl; + } + + return builtin_decl_for_precision (double_built_in, + gfc_real_kinds[i].mode_precision); } -real_compnt_info; -enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR }; /* Evaluate the arguments to an intrinsic function. The value of NARGS may be less than the actual number of arguments in EXPR @@ -242,7 +278,7 @@ gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr) int nargs; nargs = gfc_intrinsic_argument_list_length (expr); - args = (tree *) alloca (sizeof (tree) * nargs); + args = XALLOCAVEC (tree, nargs); /* Evaluate all the arguments passed. Whilst we're only interested in the first one here, there are other parts of the front-end that assume this @@ -295,7 +331,8 @@ gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr) tree artype; artype = TREE_TYPE (TREE_TYPE (args[0])); - args[0] = fold_build1 (REALPART_EXPR, artype, args[0]); + args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype, + args[0]); } se->expr = convert (type, args[0]); @@ -321,11 +358,12 @@ build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up) intval = gfc_evaluate_now (intval, pblock); tmp = convert (argtype, intval); - cond = fold_build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg); + cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR, + boolean_type_node, tmp, arg); - tmp = fold_build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval, - build_int_cst (type, 1)); - tmp = fold_build3 (COND_EXPR, type, cond, intval, tmp); + tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type, + intval, build_int_cst (type, 1)); + tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp); return tmp; } @@ -355,14 +393,10 @@ build_round_expr (tree arg, tree restype) gcc_unreachable (); /* Now, depending on the argument type, we choose between intrinsics. */ - if (argprec == TYPE_PRECISION (float_type_node)) - fn = built_in_decls[longlong ? BUILT_IN_LLROUNDF : BUILT_IN_LROUNDF]; - else if (argprec == TYPE_PRECISION (double_type_node)) - fn = built_in_decls[longlong ? BUILT_IN_LLROUND : BUILT_IN_LROUND]; - else if (argprec == TYPE_PRECISION (long_double_type_node)) - fn = built_in_decls[longlong ? BUILT_IN_LLROUNDL : BUILT_IN_LROUNDL]; + if (longlong) + fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec); else - gcc_unreachable (); + fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec); return fold_convert (restype, build_call_expr_loc (input_location, fn, 1, arg)); @@ -392,7 +426,7 @@ build_fix_expr (stmtblock_t * pblock, tree arg, tree type, break; case RND_TRUNC: - return fold_build1 (FIX_TRUNC_EXPR, type, arg); + return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg); break; default: @@ -418,51 +452,24 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op) tree arg[2]; tree tmp; tree cond; + tree decl; mpfr_t huge; int n, nargs; int kind; kind = expr->ts.kind; - nargs = gfc_intrinsic_argument_list_length (expr); + nargs = gfc_intrinsic_argument_list_length (expr); - n = END_BUILTINS; + decl = NULL_TREE; /* We have builtin functions for some cases. */ switch (op) { case RND_ROUND: - switch (kind) - { - case 4: - n = BUILT_IN_ROUNDF; - break; - - case 8: - n = BUILT_IN_ROUND; - break; - - case 10: - case 16: - n = BUILT_IN_ROUNDL; - break; - } + decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind); break; case RND_TRUNC: - switch (kind) - { - case 4: - n = BUILT_IN_TRUNCF; - break; - - case 8: - n = BUILT_IN_TRUNC; - break; - - case 10: - case 16: - n = BUILT_IN_TRUNCL; - break; - } + decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind); break; default: @@ -474,11 +481,9 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op) gfc_conv_intrinsic_function_args (se, expr, arg, nargs); /* Use a builtin function if one exists. */ - if (n != END_BUILTINS) + if (decl != NULL_TREE) { - tmp = built_in_decls[n]; - se->expr = build_call_expr_loc (input_location, - tmp, 1, arg[0]); + se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]); return; } @@ -493,17 +498,21 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op) n = gfc_validate_kind (BT_INTEGER, kind, false); mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE); tmp = gfc_conv_mpfr_to_tree (huge, kind, 0); - cond = fold_build2 (LT_EXPR, boolean_type_node, arg[0], tmp); + cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, arg[0], + tmp); mpfr_neg (huge, huge, GFC_RND_MODE); tmp = gfc_conv_mpfr_to_tree (huge, kind, 0); - tmp = fold_build2 (GT_EXPR, boolean_type_node, arg[0], tmp); - cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp); + tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, arg[0], + tmp); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, + cond, tmp); itype = gfc_get_int_type (kind); tmp = build_fix_expr (&se->pre, arg[0], itype, op); tmp = convert (type, tmp); - se->expr = fold_build3 (COND_EXPR, type, cond, tmp, arg[0]); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp, + arg[0]); mpfr_clear (huge); } @@ -518,7 +527,7 @@ gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op) int nargs; nargs = gfc_intrinsic_argument_list_length (expr); - args = (tree *) alloca (sizeof (tree) * nargs); + args = XALLOCAVEC (tree, nargs); /* Evaluate the argument, we process all arguments even though we only use the first one for code generation purposes. */ @@ -541,7 +550,8 @@ gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op) tree artype; artype = TREE_TYPE (TREE_TYPE (args[0])); - args[0] = fold_build1 (REALPART_EXPR, artype, args[0]); + args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype, + args[0]); } se->expr = build_fix_expr (&se->pre, args[0], type, op); @@ -557,7 +567,8 @@ gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr) tree arg; gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - se->expr = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg); + se->expr = fold_build1_loc (input_location, IMAGPART_EXPR, + TREE_TYPE (TREE_TYPE (arg)), arg); } @@ -569,10 +580,32 @@ gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr) tree arg; gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - se->expr = fold_build1 (CONJ_EXPR, TREE_TYPE (arg), arg); + se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg); +} + + + +static tree +define_quad_builtin (const char *name, tree type, bool is_const) +{ + tree fndecl; + fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name), + type); + + /* Mark the decl as external. */ + DECL_EXTERNAL (fndecl) = 1; + TREE_PUBLIC (fndecl) = 1; + + /* Mark it __attribute__((const)). */ + TREE_READONLY (fndecl) = is_const; + + rest_of_decl_compilation (fndecl, 1, 0); + + return fndecl; } + /* Initialize function decls for library functions. The external functions are created as required. Builtin functions are added here. */ @@ -580,26 +613,102 @@ void gfc_build_intrinsic_lib_fndecls (void) { gfc_intrinsic_map_t *m; + tree quad_decls[END_BUILTINS + 1]; + + if (gfc_real16_is_float128) + { + /* If we have soft-float types, we create the decls for their + C99-like library functions. For now, we only handle __float128 + q-suffixed functions. */ + + tree tmp, func_1, func_2, func_cabs, func_frexp; + tree func_lround, func_llround, func_scalbn, func_cpow; + + memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1)); + + /* type (*) (type) */ + tmp = tree_cons (NULL_TREE, float128_type_node, void_list_node); + func_1 = build_function_type (float128_type_node, tmp); + /* long (*) (type) */ + func_lround = build_function_type (long_integer_type_node, tmp); + /* long long (*) (type) */ + func_llround = build_function_type (long_long_integer_type_node, tmp); + /* type (*) (type, type) */ + tmp = tree_cons (NULL_TREE, float128_type_node, tmp); + func_2 = build_function_type (float128_type_node, tmp); + /* type (*) (type, &int) */ + tmp = tree_cons (NULL_TREE, float128_type_node, void_list_node); + tmp = tree_cons (NULL_TREE, build_pointer_type (integer_type_node), tmp); + func_frexp = build_function_type (float128_type_node, tmp); + /* type (*) (type, int) */ + tmp = tree_cons (NULL_TREE, float128_type_node, void_list_node); + tmp = tree_cons (NULL_TREE, integer_type_node, tmp); + func_scalbn = build_function_type (float128_type_node, tmp); + /* type (*) (complex type) */ + tmp = tree_cons (NULL_TREE, complex_float128_type_node, void_list_node); + func_cabs = build_function_type (float128_type_node, tmp); + /* complex type (*) (complex type, complex type) */ + tmp = tree_cons (NULL_TREE, complex_float128_type_node, tmp); + func_cpow = build_function_type (complex_float128_type_node, tmp); + +#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) +#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) +#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) + + /* Only these built-ins are actually needed here. These are used directly + from the code, when calling builtin_decl_for_precision() or + builtin_decl_for_float_type(). The others are all constructed by + gfc_get_intrinsic_lib_fndecl(). */ +#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \ + quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST); + +#include "mathbuiltins.def" + +#undef OTHER_BUILTIN +#undef LIB_FUNCTION +#undef DEFINE_MATH_BUILTIN +#undef DEFINE_MATH_BUILTIN_C + + } /* Add GCC builtin functions. */ - for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++) - { - if (m->code_r4 != END_BUILTINS) - m->real4_decl = built_in_decls[m->code_r4]; - if (m->code_r8 != END_BUILTINS) - m->real8_decl = built_in_decls[m->code_r8]; - if (m->code_r10 != END_BUILTINS) - m->real10_decl = built_in_decls[m->code_r10]; - if (m->code_r16 != END_BUILTINS) - m->real16_decl = built_in_decls[m->code_r16]; - if (m->code_c4 != END_BUILTINS) - m->complex4_decl = built_in_decls[m->code_c4]; - if (m->code_c8 != END_BUILTINS) - m->complex8_decl = built_in_decls[m->code_c8]; - if (m->code_c10 != END_BUILTINS) - m->complex10_decl = built_in_decls[m->code_c10]; - if (m->code_c16 != END_BUILTINS) - m->complex16_decl = built_in_decls[m->code_c16]; + for (m = gfc_intrinsic_map; + m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++) + { + if (m->float_built_in != END_BUILTINS) + m->real4_decl = built_in_decls[m->float_built_in]; + if (m->complex_float_built_in != END_BUILTINS) + m->complex4_decl = built_in_decls[m->complex_float_built_in]; + if (m->double_built_in != END_BUILTINS) + m->real8_decl = built_in_decls[m->double_built_in]; + if (m->complex_double_built_in != END_BUILTINS) + m->complex8_decl = built_in_decls[m->complex_double_built_in]; + + /* If real(kind=10) exists, it is always long double. */ + if (m->long_double_built_in != END_BUILTINS) + m->real10_decl = built_in_decls[m->long_double_built_in]; + if (m->complex_long_double_built_in != END_BUILTINS) + m->complex10_decl = built_in_decls[m->complex_long_double_built_in]; + + if (!gfc_real16_is_float128) + { + if (m->long_double_built_in != END_BUILTINS) + m->real16_decl = built_in_decls[m->long_double_built_in]; + if (m->complex_long_double_built_in != END_BUILTINS) + m->complex16_decl = built_in_decls[m->complex_long_double_built_in]; + } + else if (quad_decls[m->double_built_in] != NULL_TREE) + { + /* Quad-precision function calls are constructed when first + needed by builtin_decl_for_precision(), except for those + that will be used directly (define by OTHER_BUILTIN). */ + m->real16_decl = quad_decls[m->double_built_in]; + } + else if (quad_decls[m->complex_double_built_in] != NULL_TREE) + { + /* Same thing for the complex ones. */ + m->complex16_decl = quad_decls[m->double_built_in]; + } } } @@ -668,18 +777,21 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr) if (m->libm_name) { - if (ts->kind == 4) + int n = gfc_validate_kind (BT_REAL, ts->kind, false); + if (gfc_real_kinds[n].c_float) snprintf (name, sizeof (name), "%s%s%s", - ts->type == BT_COMPLEX ? "c" : "", m->name, "f"); - else if (ts->kind == 8) + ts->type == BT_COMPLEX ? "c" : "", m->name, "f"); + else if (gfc_real_kinds[n].c_double) snprintf (name, sizeof (name), "%s%s", - ts->type == BT_COMPLEX ? "c" : "", m->name); + ts->type == BT_COMPLEX ? "c" : "", m->name); + else if (gfc_real_kinds[n].c_long_double) + snprintf (name, sizeof (name), "%s%s%s", + ts->type == BT_COMPLEX ? "c" : "", m->name, "l"); + else if (gfc_real_kinds[n].c_float128) + snprintf (name, sizeof (name), "%s%s%s", + ts->type == BT_COMPLEX ? "c" : "", m->name, "q"); else - { - gcc_assert (ts->kind == 10 || ts->kind == 16); - snprintf (name, sizeof (name), "%s%s%s", - ts->type == BT_COMPLEX ? "c" : "", m->name, "l"); - } + gcc_unreachable (); } else { @@ -694,7 +806,7 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr) type = gfc_typenode_for_spec (&actual->expr->ts); argtypes = gfc_chainon_list (argtypes, type); } - argtypes = gfc_chainon_list (argtypes, void_type_node); + argtypes = chainon (argtypes, void_list_node); type = build_function_type (gfc_typenode_for_spec (ts), argtypes); fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name), type); @@ -727,7 +839,8 @@ gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr) id = expr->value.function.isym->id; /* Find the entry for this function. */ - for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++) + for (m = gfc_intrinsic_map; + m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++) { if (id == m->id) break; @@ -741,7 +854,7 @@ gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr) /* Get the decl and generate the call. */ num_args = gfc_intrinsic_argument_list_length (expr); - args = (tree *) alloca (sizeof (tree) * num_args); + args = XALLOCAVEC (tree, num_args); gfc_conv_intrinsic_function_args (se, expr, args, num_args); fndecl = gfc_get_intrinsic_lib_fndecl (m, expr); @@ -768,7 +881,7 @@ gfc_trans_same_strlen_check (const char* intr_name, locus* where, return; /* Compare the two string lengths. */ - cond = fold_build2 (NE_EXPR, boolean_type_node, a, b); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, a, b); /* Output the runtime-check. */ name = gfc_build_cstring_const (intr_name); @@ -789,31 +902,16 @@ gfc_trans_same_strlen_check (const char* intr_name, locus* where, static void gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr) { - tree arg, type, res, tmp; - int frexp; + tree arg, type, res, tmp, frexp; - switch (expr->value.function.actual->expr->ts.kind) - { - case 4: - frexp = BUILT_IN_FREXPF; - break; - case 8: - frexp = BUILT_IN_FREXP; - break; - case 10: - case 16: - frexp = BUILT_IN_FREXPL; - break; - default: - gcc_unreachable (); - } + frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, + expr->value.function.actual->expr->ts.kind); gfc_conv_intrinsic_function_args (se, expr, &arg, 1); res = gfc_create_var (integer_type_node, NULL); - tmp = build_call_expr_loc (input_location, - built_in_decls[frexp], 2, arg, - gfc_build_addr_expr (NULL_TREE, res)); + tmp = build_call_expr_loc (input_location, frexp, 2, arg, + gfc_build_addr_expr (NULL_TREE, res)); gfc_add_expr_to_block (&se->pre, tmp); type = gfc_typenode_for_spec (&expr->ts); @@ -850,8 +948,9 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) gcc_assert (se->ss->expr == expr); gfc_advance_se_ss_chain (se); bound = se->loop->loopvar[0]; - bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound, - se->loop->from[0]); + bound = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, bound, + se->loop->from[0]); } else { @@ -862,8 +961,9 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) gfc_add_block_to_block (&se->pre, &argse.pre); bound = argse.expr; /* Convert from one based to zero based. */ - bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound, - gfc_index_one_node); + bound = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, bound, + gfc_index_one_node); } /* TODO: don't re-evaluate the descriptor on each iteration. */ @@ -893,11 +993,13 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) { bound = gfc_evaluate_now (bound, &se->pre); - cond = fold_build2 (LT_EXPR, boolean_type_node, - bound, build_int_cst (TREE_TYPE (bound), 0)); + cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + bound, build_int_cst (TREE_TYPE (bound), 0)); tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; - tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp); - cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp); + tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + bound, tmp); + cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + boolean_type_node, cond, tmp); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, gfc_msg_fault); } @@ -933,53 +1035,63 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) { tree stride = gfc_conv_descriptor_stride_get (desc, bound); - cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound); - - cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride, - gfc_index_zero_node); - cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1); - - cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride, - gfc_index_zero_node); + cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + ubound, lbound); + cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + stride, gfc_index_zero_node); + cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, cond3, cond1); + cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + stride, gfc_index_zero_node); if (upper) { tree cond5; - cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4); - - cond5 = fold_build2 (EQ_EXPR, boolean_type_node, gfc_index_one_node, lbound); - cond5 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond5); - - cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond5); - - se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond, - ubound, gfc_index_zero_node); + cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, cond3, cond4); + cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + gfc_index_one_node, lbound); + cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, cond4, cond5); + + cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, cond, cond5); + + se->expr = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, cond, + ubound, gfc_index_zero_node); } else { if (as->type == AS_ASSUMED_SIZE) - cond = fold_build2 (EQ_EXPR, boolean_type_node, bound, - build_int_cst (TREE_TYPE (bound), - arg->expr->rank - 1)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + bound, build_int_cst (TREE_TYPE (bound), + arg->expr->rank - 1)); else cond = boolean_false_node; - cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4); - cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1); + cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, cond3, cond4); + cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, cond, cond1); - se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond, - lbound, gfc_index_one_node); + se->expr = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, cond, + lbound, gfc_index_one_node); } } else { if (upper) { - size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound); - se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size, + size = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, ubound, lbound); + se->expr = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, size, gfc_index_one_node); - se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr, - gfc_index_zero_node); + se->expr = fold_build2_loc (input_location, MAX_EXPR, + gfc_array_index_type, se->expr, + gfc_index_zero_node); } else se->expr = gfc_index_one_node; @@ -993,8 +1105,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) static void gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) { - tree arg; - int n; + tree arg, cabs; gfc_conv_intrinsic_function_args (se, expr, &arg, 1); @@ -1002,27 +1113,13 @@ gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) { case BT_INTEGER: case BT_REAL: - se->expr = fold_build1 (ABS_EXPR, TREE_TYPE (arg), arg); + se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg), + arg); break; case BT_COMPLEX: - switch (expr->ts.kind) - { - case 4: - n = BUILT_IN_CABSF; - break; - case 8: - n = BUILT_IN_CABS; - break; - case 10: - case 16: - n = BUILT_IN_CABSL; - break; - default: - gcc_unreachable (); - } - se->expr = build_call_expr_loc (input_location, - built_in_decls[n], 1, arg); + cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind); + se->expr = build_call_expr_loc (input_location, cabs, 1, arg); break; default: @@ -1043,7 +1140,7 @@ gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both) unsigned int num_args; num_args = gfc_intrinsic_argument_list_length (expr); - args = (tree *) alloca (sizeof (tree) * num_args); + args = XALLOCAVEC (tree, num_args); type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, args, num_args); @@ -1052,14 +1149,14 @@ gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both) imag = convert (TREE_TYPE (type), args[1]); else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE) { - imag = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])), - args[0]); + imag = fold_build1_loc (input_location, IMAGPART_EXPR, + TREE_TYPE (TREE_TYPE (args[0])), args[0]); imag = convert (TREE_TYPE (type), imag); } else imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node); - se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag); + se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag); } /* Remainder function MOD(A, P) = A - INT(A / P) * P @@ -1074,6 +1171,7 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) tree tmp; tree test; tree test2; + tree fmod; mpfr_t huge; int n, ikind; tree args[2]; @@ -1087,39 +1185,24 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) type = TREE_TYPE (args[0]); if (modulo) - se->expr = fold_build2 (FLOOR_MOD_EXPR, type, args[0], args[1]); + se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type, + args[0], args[1]); else - se->expr = fold_build2 (TRUNC_MOD_EXPR, type, args[0], args[1]); + se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type, + args[0], args[1]); break; case BT_REAL: - n = END_BUILTINS; + fmod = NULL_TREE; /* Check if we have a builtin fmod. */ - switch (expr->ts.kind) - { - case 4: - n = BUILT_IN_FMODF; - break; - - case 8: - n = BUILT_IN_FMOD; - break; - - case 10: - case 16: - n = BUILT_IN_FMODL; - break; - - default: - break; - } + fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind); /* Use it if it exists. */ - if (n != END_BUILTINS) + if (fmod != NULL_TREE) { - tmp = build_addr (built_in_decls[n], current_function_decl); + tmp = build_addr (fmod, current_function_decl); se->expr = build_call_array_loc (input_location, - TREE_TYPE (TREE_TYPE (built_in_decls[n])), + TREE_TYPE (TREE_TYPE (fmod)), tmp, 2, args); if (modulo == 0) return; @@ -1137,25 +1220,30 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0)) thereby avoiding another division and retaining the accuracy of the builtin function. */ - if (n != END_BUILTINS && modulo) + if (fmod != NULL_TREE && modulo) { tree zero = gfc_build_const (type, integer_zero_node); tmp = gfc_evaluate_now (se->expr, &se->pre); - test = fold_build2 (LT_EXPR, boolean_type_node, args[0], zero); - test2 = fold_build2 (LT_EXPR, boolean_type_node, args[1], zero); - test2 = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2); - test = fold_build2 (NE_EXPR, boolean_type_node, tmp, zero); - test = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2); + test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + args[0], zero); + test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + args[1], zero); + test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR, + boolean_type_node, test, test2); + test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp, zero); + test = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, test, test2); test = gfc_evaluate_now (test, &se->pre); - se->expr = fold_build3 (COND_EXPR, type, test, - fold_build2 (PLUS_EXPR, type, tmp, args[1]), - tmp); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, test, + fold_build2_loc (input_location, PLUS_EXPR, + type, tmp, args[1]), tmp); return; } /* If we do not have a built_in fmod, the calculation is going to have to be done longhand. */ - tmp = fold_build2 (RDIV_EXPR, type, args[0], args[1]); + tmp = fold_build2_loc (input_location, RDIV_EXPR, type, args[0], args[1]); /* Test if the value is too large to handle sensibly. */ gfc_set_model_kind (expr->ts.kind); @@ -1169,12 +1257,15 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) } mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE); test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0); - test2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, test); + test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + tmp, test); mpfr_neg (huge, huge, GFC_RND_MODE); test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0); - test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test); - test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2); + test = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp, + test); + test2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, test, test2); itype = gfc_get_int_type (ikind); if (modulo) @@ -1182,9 +1273,11 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) else tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC); tmp = convert (type, tmp); - tmp = fold_build3 (COND_EXPR, type, test2, tmp, args[0]); - tmp = fold_build2 (MULT_EXPR, type, tmp, args[1]); - se->expr = fold_build2 (MINUS_EXPR, type, args[0], tmp); + tmp = fold_build3_loc (input_location, COND_EXPR, type, test2, tmp, + args[0]); + tmp = fold_build2_loc (input_location, MULT_EXPR, type, tmp, args[1]); + se->expr = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], + tmp); mpfr_clear (huge); break; @@ -1193,6 +1286,62 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) } } +/* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S)) + DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S) + where the right shifts are logical (i.e. 0's are shifted in). + Because SHIFT_EXPR's want shifts strictly smaller than the integral + type width, we have to special-case both S == 0 and S == BITSIZE(J): + DSHIFTL(I,J,0) = I + DSHIFTL(I,J,BITSIZE) = J + DSHIFTR(I,J,0) = J + DSHIFTR(I,J,BITSIZE) = I. */ + +static void +gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl) +{ + tree type, utype, stype, arg1, arg2, shift, res, left, right; + tree args[3], cond, tmp; + int bitsize; + + gfc_conv_intrinsic_function_args (se, expr, args, 3); + + gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1])); + type = TREE_TYPE (args[0]); + bitsize = TYPE_PRECISION (type); + utype = unsigned_type_for (type); + stype = TREE_TYPE (args[2]); + + arg1 = gfc_evaluate_now (args[0], &se->pre); + arg2 = gfc_evaluate_now (args[1], &se->pre); + shift = gfc_evaluate_now (args[2], &se->pre); + + /* The generic case. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, stype, + build_int_cst (stype, bitsize), shift); + left = fold_build2_loc (input_location, LSHIFT_EXPR, type, + arg1, dshiftl ? shift : tmp); + + right = fold_build2_loc (input_location, RSHIFT_EXPR, utype, + fold_convert (utype, arg2), dshiftl ? tmp : shift); + right = fold_convert (type, right); + + res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right); + + /* Special cases. */ + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift, + build_int_cst (stype, 0)); + res = fold_build3_loc (input_location, COND_EXPR, type, cond, + dshiftl ? arg1 : arg2, res); + + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift, + build_int_cst (stype, bitsize)); + res = fold_build3_loc (input_location, COND_EXPR, type, cond, + dshiftl ? arg2 : arg1, res); + + se->expr = res; +} + + /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */ static void @@ -1207,12 +1356,12 @@ gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_function_args (se, expr, args, 2); type = TREE_TYPE (args[0]); - val = fold_build2 (MINUS_EXPR, type, args[0], args[1]); + val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]); val = gfc_evaluate_now (val, &se->pre); zero = gfc_build_const (type, integer_zero_node); - tmp = fold_build2 (LE_EXPR, boolean_type_node, val, zero); - se->expr = fold_build3 (COND_EXPR, type, tmp, zero, val); + tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, val, zero); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val); } @@ -1234,24 +1383,8 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) { tree abs; - switch (expr->ts.kind) - { - case 4: - tmp = built_in_decls[BUILT_IN_COPYSIGNF]; - abs = built_in_decls[BUILT_IN_FABSF]; - break; - case 8: - tmp = built_in_decls[BUILT_IN_COPYSIGN]; - abs = built_in_decls[BUILT_IN_FABS]; - break; - case 10: - case 16: - tmp = built_in_decls[BUILT_IN_COPYSIGNL]; - abs = built_in_decls[BUILT_IN_FABSL]; - break; - default: - gcc_unreachable (); - } + tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind); + abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind); /* We explicitly have to ignore the minus sign. We do so by using result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */ @@ -1260,14 +1393,18 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) { tree cond, zero; zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node); - cond = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero); - se->expr = fold_build3 (COND_EXPR, TREE_TYPE (args[0]), cond, - build_call_expr (abs, 1, args[0]), - build_call_expr (tmp, 2, args[0], args[1])); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + args[1], zero); + se->expr = fold_build3_loc (input_location, COND_EXPR, + TREE_TYPE (args[0]), cond, + build_call_expr_loc (input_location, abs, 1, + args[0]), + build_call_expr_loc (input_location, tmp, 2, + args[0], args[1])); } else - se->expr = build_call_expr_loc (input_location, - tmp, 2, args[0], args[1]); + se->expr = build_call_expr_loc (input_location, tmp, 2, + args[0], args[1]); return; } @@ -1280,16 +1417,16 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if the signs of A and B are the same, and of all ones if they differ. */ - tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]); - tmp = fold_build2 (RSHIFT_EXPR, type, tmp, - build_int_cst (type, TYPE_PRECISION (type) - 1)); + tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]); + tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp, + build_int_cst (type, TYPE_PRECISION (type) - 1)); tmp = gfc_evaluate_now (tmp, &se->pre); /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp] is all ones (i.e. -1). */ - se->expr = fold_build2 (BIT_XOR_EXPR, type, - fold_build2 (PLUS_EXPR, type, args[0], tmp), - tmp); + se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type, + fold_build2_loc (input_location, PLUS_EXPR, + type, args[0], tmp), tmp); } @@ -1321,7 +1458,8 @@ gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr) type = gfc_typenode_for_spec (&expr->ts); args[0] = convert (type, args[0]); args[1] = convert (type, args[1]); - se->expr = fold_build2 (MULT_EXPR, type, args[0], args[1]); + se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0], + args[1]); } @@ -1341,10 +1479,10 @@ gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr) type = gfc_get_char_type (expr->ts.kind); var = gfc_create_var (type, "char"); - arg[0] = fold_build1 (NOP_EXPR, type, arg[0]); + arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]); gfc_add_modify (&se->pre, var, arg[0]); se->expr = gfc_build_addr_expr (build_pointer_type (type), var); - se->string_length = integer_one_node; + se->string_length = build_int_cst (gfc_charlen_type_node, 1); } @@ -1360,7 +1498,7 @@ gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr) unsigned int num_args; num_args = gfc_intrinsic_argument_list_length (expr) + 2; - args = (tree *) alloca (sizeof (tree) * num_args); + args = XALLOCAVEC (tree, num_args); var = gfc_create_var (pchar_type_node, "pstr"); len = gfc_create_var (gfc_get_int_type (8), "len"); @@ -1376,8 +1514,8 @@ gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr) gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ - cond = fold_build2 (GT_EXPR, boolean_type_node, - len, build_int_cst (TREE_TYPE (len), 0)); + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + len, build_int_cst (TREE_TYPE (len), 0)); tmp = gfc_call_free (var); tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->post, tmp); @@ -1399,10 +1537,10 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) unsigned int num_args; num_args = gfc_intrinsic_argument_list_length (expr) + 2; - args = (tree *) alloca (sizeof (tree) * num_args); + args = XALLOCAVEC (tree, num_args); var = gfc_create_var (pchar_type_node, "pstr"); - len = gfc_create_var (gfc_get_int_type (4), "len"); + len = gfc_create_var (gfc_charlen_type_node, "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); args[0] = gfc_build_addr_expr (NULL_TREE, var); @@ -1415,8 +1553,8 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ - cond = fold_build2 (GT_EXPR, boolean_type_node, - len, build_int_cst (TREE_TYPE (len), 0)); + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + len, build_int_cst (TREE_TYPE (len), 0)); tmp = gfc_call_free (var); tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->post, tmp); @@ -1440,10 +1578,10 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr) unsigned int num_args; num_args = gfc_intrinsic_argument_list_length (expr) + 2; - args = (tree *) alloca (sizeof (tree) * num_args); + args = XALLOCAVEC (tree, num_args); var = gfc_create_var (pchar_type_node, "pstr"); - len = gfc_create_var (gfc_get_int_type (4), "len"); + len = gfc_create_var (gfc_charlen_type_node, "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); args[0] = gfc_build_addr_expr (NULL_TREE, var); @@ -1456,8 +1594,8 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr) gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ - cond = fold_build2 (GT_EXPR, boolean_type_node, - len, build_int_cst (TREE_TYPE (len), 0)); + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + len, build_int_cst (TREE_TYPE (len), 0)); tmp = gfc_call_free (var); tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->post, tmp); @@ -1495,7 +1633,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) unsigned int i, nargs; nargs = gfc_intrinsic_argument_list_length (expr); - args = (tree *) alloca (sizeof (tree) * nargs); + args = XALLOCAVEC (tree, nargs); gfc_conv_intrinsic_function_args (se, expr, args, nargs); type = gfc_typenode_for_spec (&expr->ts); @@ -1534,7 +1672,8 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val)); - tmp = fold_build2 (op, boolean_type_node, convert (type, val), mvar); + tmp = fold_build2_loc (input_location, op, boolean_type_node, + convert (type, val), mvar); /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to __builtin_isnan might be made dependent on that module being loaded, @@ -1543,8 +1682,9 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) { isnan = build_call_expr_loc (input_location, built_in_decls[BUILT_IN_ISNAN], 1, mvar); - tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, - fold_convert (boolean_type_node, isnan)); + tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, tmp, + fold_convert (boolean_type_node, isnan)); } tmp = build3_v (COND_EXPR, tmp, thencase, build_empty_stmt (input_location)); @@ -1570,7 +1710,7 @@ gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op) unsigned int nargs; nargs = gfc_intrinsic_argument_list_length (expr); - args = (tree *) alloca (sizeof (tree) * (nargs + 4)); + args = XALLOCAVEC (tree, nargs + 4); gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs); /* Create the result variables. */ @@ -1596,8 +1736,8 @@ gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op) gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ - cond = fold_build2 (GT_EXPR, boolean_type_node, - len, build_int_cst (TREE_TYPE (len), 0)); + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + len, build_int_cst (TREE_TYPE (len), 0)); tmp = gfc_call_free (var); tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->post, tmp); @@ -1634,7 +1774,8 @@ gfc_get_symbol_for_expr (gfc_expr * expr) sym->as->rank = expr->rank; } - /* TODO: proper argument lists for external intrinsics. */ + gfc_copy_formal_args_intr (sym, expr->value.function.isym); + return sym; } @@ -1643,7 +1784,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); @@ -1656,7 +1797,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) { @@ -1684,19 +1825,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); } } @@ -1794,8 +1935,8 @@ gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_conv_expr_val (&arrayse, actual->expr); gfc_add_block_to_block (&body, &arrayse.pre); - tmp = fold_build2 (op, boolean_type_node, arrayse.expr, - build_int_cst (TREE_TYPE (arrayse.expr), 0)); + tmp = fold_build2_loc (input_location, op, boolean_type_node, arrayse.expr, + build_int_cst (TREE_TYPE (arrayse.expr), 0)); tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); gfc_add_block_to_block (&body, &arrayse.post); @@ -1855,8 +1996,8 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr) /* Generate the loop body. */ gfc_start_scalarized_body (&loop, &body); - tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (resvar), - resvar, build_int_cst (TREE_TYPE (resvar), 1)); + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar), + resvar, build_int_cst (TREE_TYPE (resvar), 1)); tmp = build2_v (MODIFY_EXPR, resvar, tmp); gfc_init_se (&arrayse, NULL); @@ -1881,9 +2022,11 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr) /* Inline implementation of the sum and product intrinsics. */ static void -gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op) +gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, + bool norm2) { tree resvar; + tree scale = NULL_TREE; tree type; stmtblock_t body; stmtblock_t block; @@ -1906,8 +2049,23 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op) type = gfc_typenode_for_spec (&expr->ts); /* Initialize the result. */ resvar = gfc_create_var (type, "val"); - if (op == PLUS_EXPR) + if (norm2) + { + /* result = 0.0; + scale = 1.0. */ + scale = gfc_create_var (type, "scale"); + gfc_add_modify (&se->pre, scale, + gfc_build_const (type, integer_one_node)); + tmp = gfc_build_const (type, integer_zero_node); + } + else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR) tmp = gfc_build_const (type, integer_zero_node); + else if (op == NE_EXPR) + /* PARITY. */ + tmp = convert (type, boolean_false_node); + else if (op == BIT_AND_EXPR) + tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR, + type, integer_one_node)); else tmp = gfc_build_const (type, integer_one_node); @@ -1919,9 +2077,16 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op) arrayss = gfc_walk_expr (arrayexpr); gcc_assert (arrayss != gfc_ss_terminator); - actual = actual->next->next; - gcc_assert (actual); - maskexpr = actual->expr; + if (op == NE_EXPR || norm2) + /* PARITY and NORM2. */ + maskexpr = NULL; + else + { + actual = actual->next->next; + gcc_assert (actual); + maskexpr = actual->expr; + } + if (maskexpr && maskexpr->rank != 0) { maskss = gfc_walk_expr (maskexpr); @@ -1967,15 +2132,82 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_conv_expr_val (&arrayse, arrayexpr); gfc_add_block_to_block (&block, &arrayse.pre); - tmp = fold_build2 (op, type, resvar, arrayse.expr); - gfc_add_modify (&block, resvar, tmp); + if (norm2) + { + /* if (x(i) != 0.0) + { + absX = abs(x(i)) + if (absX > scale) + { + val = scale/absX; + result = 1.0 + result * val * val; + scale = absX; + } + else + { + val = absX/scale; + result += val * val; + } + } */ + tree res1, res2, cond, absX, val; + stmtblock_t ifblock1, ifblock2, ifblock3; + + gfc_init_block (&ifblock1); + + absX = gfc_create_var (type, "absX"); + gfc_add_modify (&ifblock1, absX, + fold_build1_loc (input_location, ABS_EXPR, type, + arrayse.expr)); + val = gfc_create_var (type, "val"); + gfc_add_expr_to_block (&ifblock1, val); + + gfc_init_block (&ifblock2); + gfc_add_modify (&ifblock2, val, + fold_build2_loc (input_location, RDIV_EXPR, type, scale, + absX)); + res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val); + res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1); + res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1, + gfc_build_const (type, integer_one_node)); + gfc_add_modify (&ifblock2, resvar, res1); + gfc_add_modify (&ifblock2, scale, absX); + res1 = gfc_finish_block (&ifblock2); + + gfc_init_block (&ifblock3); + gfc_add_modify (&ifblock3, val, + fold_build2_loc (input_location, RDIV_EXPR, type, absX, + scale)); + res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val); + res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2); + gfc_add_modify (&ifblock3, resvar, res2); + res2 = gfc_finish_block (&ifblock3); + + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + absX, scale); + tmp = build3_v (COND_EXPR, cond, res1, res2); + gfc_add_expr_to_block (&ifblock1, tmp); + tmp = gfc_finish_block (&ifblock1); + + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + arrayse.expr, + gfc_build_const (type, integer_zero_node)); + + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + else + { + tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr); + gfc_add_modify (&block, resvar, tmp); + } + gfc_add_block_to_block (&block, &arrayse.post); if (maskss) { /* We enclose the above in if (mask) {...} . */ - tmp = gfc_finish_block (&block); + tmp = gfc_finish_block (&block); tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt (input_location)); } @@ -2008,6 +2240,16 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_cleanup_loop (&loop); + if (norm2) + { + /* result = scale * sqrt(result). */ + tree sqrt; + sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind); + resvar = build_call_expr_loc (input_location, + sqrt, 1, resvar); + resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar); + } + se->expr = resvar; } @@ -2073,7 +2315,8 @@ gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr) arrayse1.ss = arrayss1; gfc_conv_expr_val (&arrayse1, arrayexpr1); if (expr->ts.type == BT_COMPLEX) - arrayse1.expr = fold_build1 (CONJ_EXPR, type, arrayse1.expr); + arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type, + arrayse1.expr); gfc_add_block_to_block (&block, &arrayse1.pre); /* Make the tree expression for array2. */ @@ -2086,13 +2329,15 @@ gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr) /* Do the actual product and sum. */ if (expr->ts.type == BT_LOGICAL) { - tmp = fold_build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr); - tmp = fold_build2 (TRUTH_OR_EXPR, type, resvar, tmp); + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type, + arrayse1.expr, arrayse2.expr); + tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp); } else { - tmp = fold_build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr); - tmp = fold_build2 (PLUS_EXPR, type, resvar, tmp); + tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr, + arrayse2.expr); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp); } gfc_add_modify (&block, resvar, tmp); @@ -2235,29 +2480,22 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) { nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind); mpz_clear (asize); - nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty, - gfc_index_zero_node); + nonempty = fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, nonempty, + gfc_index_zero_node); } maskss = NULL; } limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit"); - n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false); switch (arrayexpr->ts.type) { case BT_REAL: - if (HONOR_INFINITIES (DECL_MODE (limit))) - { - REAL_VALUE_TYPE real; - real_inf (&real); - tmp = build_real (TREE_TYPE (limit), real); - } - else - tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, - arrayexpr->ts.kind, 0); + tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind); break; case BT_INTEGER: + n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false); tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, arrayexpr->ts.kind); break; @@ -2271,10 +2509,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive possible value is HUGE in both cases. */ if (op == GT_EXPR) - tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp); + tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp); if (op == GT_EXPR && expr->ts.type == BT_INTEGER) - tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp, - build_int_cst (type, 1)); + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp, + build_int_cst (type, 1)); gfc_add_modify (&se->pre, limit, tmp); @@ -2290,8 +2528,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gcc_assert (loop.dimen == 1); if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0]) - nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0], - loop.to[0]); + nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, + loop.from[0], loop.to[0]); lab1 = NULL; lab2 = NULL; @@ -2302,9 +2540,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) the inner loop. */ if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit))) gfc_add_modify (&loop.pre, pos, - fold_build3 (COND_EXPR, gfc_array_index_type, - nonempty, gfc_index_one_node, - gfc_index_zero_node)); + fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, + nonempty, gfc_index_one_node, + gfc_index_zero_node)); else { gfc_add_modify (&loop.pre, pos, gfc_index_zero_node); @@ -2350,8 +2589,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* Remember where we are. An offset must be added to the loop counter to obtain the required position. */ if (loop.from[0]) - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - gfc_index_one_node, loop.from[0]); + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + gfc_index_one_node, loop.from[0]); else tmp = gfc_index_one_node; @@ -2363,19 +2602,19 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) tree ifbody2; gfc_start_block (&ifblock2); - tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos), - loop.loopvar[0], offset); + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos), + loop.loopvar[0], offset); gfc_add_modify (&ifblock2, pos, tmp); ifbody2 = gfc_finish_block (&ifblock2); - cond = fold_build2 (EQ_EXPR, boolean_type_node, pos, - gfc_index_zero_node); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pos, + gfc_index_zero_node); tmp = build3_v (COND_EXPR, cond, ifbody2, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); } - tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos), - loop.loopvar[0], offset); + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos), + loop.loopvar[0], offset); gfc_add_modify (&ifblock, pos, tmp); if (lab1) @@ -2386,10 +2625,12 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) if (!lab1 || HONOR_NANS (DECL_MODE (limit))) { if (lab1) - cond = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR, - boolean_type_node, arrayse.expr, limit); + cond = fold_build2_loc (input_location, + op == GT_EXPR ? GE_EXPR : LE_EXPR, + boolean_type_node, arrayse.expr, limit); else - cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit); + cond = fold_build2_loc (input_location, op, boolean_type_node, + arrayse.expr, limit); ifbody = build3_v (COND_EXPR, cond, ifbody, build_empty_stmt (input_location)); @@ -2457,20 +2698,21 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* Remember where we are. An offset must be added to the loop counter to obtain the required position. */ if (loop.from[0]) - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - gfc_index_one_node, loop.from[0]); + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + gfc_index_one_node, loop.from[0]); else tmp = gfc_index_one_node; gfc_add_modify (&block, offset, tmp); - tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos), - loop.loopvar[0], offset); + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos), + loop.loopvar[0], offset); gfc_add_modify (&ifblock, pos, tmp); ifbody = gfc_finish_block (&ifblock); - cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit); + cond = fold_build2_loc (input_location, op, boolean_type_node, + arrayse.expr, limit); tmp = build3_v (COND_EXPR, cond, ifbody, build_empty_stmt (input_location)); @@ -2690,14 +2932,15 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) possible value is HUGE in both cases. */ if (op == GT_EXPR) { - tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp); + tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp); if (huge_cst) - huge_cst = fold_build1 (NEGATE_EXPR, TREE_TYPE (huge_cst), huge_cst); + huge_cst = fold_build1_loc (input_location, NEGATE_EXPR, + TREE_TYPE (huge_cst), huge_cst); } if (op == GT_EXPR && expr->ts.type == BT_INTEGER) - tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), - tmp, build_int_cst (type, 1)); + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), + tmp, build_int_cst (type, 1)); gfc_add_modify (&se->pre, limit, tmp); @@ -2723,8 +2966,9 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) { nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind); mpz_clear (asize); - nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty, - gfc_index_zero_node); + nonempty = fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, nonempty, + gfc_index_zero_node); } maskss = NULL; } @@ -2741,8 +2985,8 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) if (nonempty == NULL && maskss == NULL && loop.dimen == 1 && loop.from[0] && loop.to[0]) - nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0], - loop.to[0]); + nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, + loop.from[0], loop.to[0]); nonempty_var = NULL; if (nonempty == NULL && (HONOR_INFINITIES (DECL_MODE (limit)) @@ -2802,8 +3046,8 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) if (HONOR_NANS (DECL_MODE (limit))) { - tmp = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR, - boolean_type_node, arrayse.expr, limit); + tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR, + boolean_type_node, arrayse.expr, limit); if (lab) ifbody = build1_v (GOTO_EXPR, lab); else @@ -2825,7 +3069,8 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) signed zeros. */ if (HONOR_SIGNED_ZEROS (DECL_MODE (limit))) { - tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit); + tmp = fold_build2_loc (input_location, op, boolean_type_node, + arrayse.expr, limit); ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt (input_location)); @@ -2833,8 +3078,9 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) } else { - tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR, - type, arrayse.expr, limit); + tmp = fold_build2_loc (input_location, + op == GT_EXPR ? MAX_EXPR : MIN_EXPR, + type, arrayse.expr, limit); gfc_add_modify (&block2, limit, tmp); } } @@ -2848,15 +3094,17 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) if (HONOR_NANS (DECL_MODE (limit)) || HONOR_SIGNED_ZEROS (DECL_MODE (limit))) { - tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit); + tmp = fold_build2_loc (input_location, op, boolean_type_node, + arrayse.expr, limit); ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); ifbody = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt (input_location)); } else { - tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR, - type, arrayse.expr, limit); + tmp = fold_build2_loc (input_location, + op == GT_EXPR ? MAX_EXPR : MIN_EXPR, + type, arrayse.expr, limit); ifbody = build2_v (MODIFY_EXPR, limit, tmp); } tmp = build3_v (COND_EXPR, fast, ifbody, elsebody); @@ -2878,7 +3126,8 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) { gfc_trans_scalarized_loop_end (&loop, 0, &body); - tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst); + tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, + nan_cst, huge_cst); gfc_add_modify (&loop.code[0], limit, tmp); gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab)); @@ -2910,7 +3159,8 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) if (HONOR_NANS (DECL_MODE (limit)) || HONOR_SIGNED_ZEROS (DECL_MODE (limit))) { - tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit); + tmp = fold_build2_loc (input_location, op, boolean_type_node, + arrayse.expr, limit); ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt (input_location)); @@ -2918,8 +3168,9 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) } else { - tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR, - type, arrayse.expr, limit); + tmp = fold_build2_loc (input_location, + op == GT_EXPR ? MAX_EXPR : MIN_EXPR, + type, arrayse.expr, limit); gfc_add_modify (&block, limit, tmp); } @@ -2939,7 +3190,8 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) if (fast) { - tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst); + tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, + nan_cst, huge_cst); ifbody = build2_v (MODIFY_EXPR, limit, tmp); tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location), ifbody); @@ -2947,7 +3199,8 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) } else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab) { - tmp = fold_build3 (COND_EXPR, type, nonempty, limit, huge_cst); + tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit, + huge_cst); gfc_add_modify (&loop.pre, limit, tmp); } @@ -2993,14 +3246,42 @@ gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_function_args (se, expr, args, 2); type = TREE_TYPE (args[0]); - tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]); - tmp = fold_build2 (BIT_AND_EXPR, type, args[0], tmp); - tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, - build_int_cst (type, 0)); + tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type, + build_int_cst (type, 1), args[1]); + tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, + build_int_cst (type, 0)); type = gfc_typenode_for_spec (&expr->ts); se->expr = convert (type, tmp); } + +/* Generate code for BGE, BGT, BLE and BLT intrinsics. */ +static void +gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op) +{ + tree args[2]; + + gfc_conv_intrinsic_function_args (se, expr, args, 2); + + /* Convert both arguments to the unsigned type of the same size. */ + args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]); + args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]); + + /* If they have unequal type size, convert to the larger one. */ + if (TYPE_PRECISION (TREE_TYPE (args[0])) + > TYPE_PRECISION (TREE_TYPE (args[1]))) + args[1] = fold_convert (TREE_TYPE (args[0]), args[1]); + else if (TYPE_PRECISION (TREE_TYPE (args[1])) + > TYPE_PRECISION (TREE_TYPE (args[0]))) + args[0] = fold_convert (TREE_TYPE (args[1]), args[0]); + + /* Now, we compare them. */ + se->expr = fold_build2_loc (input_location, op, boolean_type_node, + args[0], args[1]); +} + + /* Generate code to perform the specified operation. */ static void gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op) @@ -3008,7 +3289,8 @@ gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op) tree args[2]; gfc_conv_intrinsic_function_args (se, expr, args, 2); - se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]); + se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]), + args[0], args[1]); } /* Bitwise not. */ @@ -3018,7 +3300,8 @@ gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr) tree arg; gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - se->expr = fold_build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg); + se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR, + TREE_TYPE (arg), arg); } /* Set or clear a single bit. */ @@ -3033,15 +3316,16 @@ gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set) gfc_conv_intrinsic_function_args (se, expr, args, 2); type = TREE_TYPE (args[0]); - tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]); + tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type, + build_int_cst (type, 1), args[1]); if (set) op = BIT_IOR_EXPR; else { op = BIT_AND_EXPR; - tmp = fold_build1 (BIT_NOT_EXPR, type, tmp); + tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp); } - se->expr = fold_build2 (op, type, args[0], tmp); + se->expr = fold_build2_loc (input_location, op, type, args[0], tmp); } /* Extract a sequence of bits. @@ -3058,25 +3342,47 @@ gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr) type = TREE_TYPE (args[0]); mask = build_int_cst (type, -1); - mask = fold_build2 (LSHIFT_EXPR, type, mask, args[2]); - mask = fold_build1 (BIT_NOT_EXPR, type, mask); + mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]); + mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask); - tmp = fold_build2 (RSHIFT_EXPR, type, args[0], args[1]); + tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]); - se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask); + se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask); } -/* RSHIFT (I, SHIFT) = I >> SHIFT - LSHIFT (I, SHIFT) = I << SHIFT */ static void -gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift) +gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift, + bool arithmetic) { - tree args[2]; + tree args[2], type, num_bits, cond; gfc_conv_intrinsic_function_args (se, expr, args, 2); - se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR, - TREE_TYPE (args[0]), args[0], args[1]); + args[0] = gfc_evaluate_now (args[0], &se->pre); + args[1] = gfc_evaluate_now (args[1], &se->pre); + type = TREE_TYPE (args[0]); + + if (!arithmetic) + args[0] = fold_convert (unsigned_type_for (type), args[0]); + else + gcc_assert (right_shift); + + se->expr = fold_build2_loc (input_location, + right_shift ? RSHIFT_EXPR : LSHIFT_EXPR, + TREE_TYPE (args[0]), args[0], args[1]); + + if (!arithmetic) + se->expr = fold_convert (type, se->expr); + + /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas + gcc requires a shift width < BIT_SIZE(I), so we have to catch this + special case. */ + num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type)); + cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + args[1], num_bits); + + se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, + build_int_cst (type, 0), se->expr); } /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i)) @@ -3097,34 +3403,39 @@ gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr) tree rshift; gfc_conv_intrinsic_function_args (se, expr, args, 2); + + args[0] = gfc_evaluate_now (args[0], &se->pre); + args[1] = gfc_evaluate_now (args[1], &se->pre); + type = TREE_TYPE (args[0]); utype = unsigned_type_for (type); - width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]); + width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]), + args[1]); /* Left shift if positive. */ - lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width); + lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width); /* Right shift if negative. We convert to an unsigned type because we want a logical shift. The standard doesn't define the case of shifting negative numbers, and we try to be compatible with other compilers, most notably g77, here. */ - rshift = fold_convert (type, fold_build2 (RSHIFT_EXPR, utype, - convert (utype, args[0]), width)); + rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR, + utype, convert (utype, args[0]), width)); - tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1], - build_int_cst (TREE_TYPE (args[1]), 0)); - tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift); + tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, args[1], + build_int_cst (TREE_TYPE (args[1]), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift); /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas gcc requires a shift width < BIT_SIZE(I), so we have to catch this special case. */ num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type)); - cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits); - - se->expr = fold_build3 (COND_EXPR, type, cond, - build_int_cst (type, 0), tmp); + cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, width, + num_bits); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, + build_int_cst (type, 0), tmp); } @@ -3142,7 +3453,7 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) unsigned int num_args; num_args = gfc_intrinsic_argument_list_length (expr); - args = (tree *) alloca (sizeof (tree) * num_args); + args = XALLOCAVEC (tree, num_args); gfc_conv_intrinsic_function_args (se, expr, args, num_args); @@ -3182,7 +3493,7 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) gcc_unreachable (); } se->expr = build_call_expr_loc (input_location, - tmp, 3, args[0], args[1], args[2]); + tmp, 3, args[0], args[1], args[2]); /* Convert the result back to the original type, if we extended the first argument's width above. */ if (expr->ts.kind < 4) @@ -3192,22 +3503,31 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) } type = TREE_TYPE (args[0]); + /* Evaluate arguments only once. */ + args[0] = gfc_evaluate_now (args[0], &se->pre); + args[1] = gfc_evaluate_now (args[1], &se->pre); + /* Rotate left if positive. */ - lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]); + lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]); /* Rotate right if negative. */ - tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]); - rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp); + tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]), + args[1]); + rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp); zero = build_int_cst (TREE_TYPE (args[1]), 0); - tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero); - rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot); + tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, args[1], + zero); + rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot); /* Do nothing if shift == 0. */ - tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero); - se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, args[1], + zero); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0], + rrot); } + /* LEADZ (i) = (i == 0) ? BIT_SIZE (i) : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i)) @@ -3252,9 +3572,9 @@ gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr) } else { - gcc_assert (argsize == 128); + gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE); arg_type = gfc_build_uint_type (argsize); - func = gfor_fndecl_clz128; + func = NULL_TREE; } /* Convert the actual argument twice: first, to the unsigned type of the @@ -3262,22 +3582,76 @@ gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr) function. But the return type is of the default INTEGER kind. */ arg = fold_convert (gfc_build_uint_type (argsize), arg); arg = fold_convert (arg_type, arg); + arg = gfc_evaluate_now (arg, &se->pre); result_type = gfc_get_int_type (gfc_default_integer_kind); /* Compute LEADZ for the case i .ne. 0. */ - s = TYPE_PRECISION (arg_type) - argsize; - tmp = fold_convert (result_type, build_call_expr (func, 1, arg)); - leadz = fold_build2 (MINUS_EXPR, result_type, - tmp, build_int_cst (result_type, s)); + if (func) + { + s = TYPE_PRECISION (arg_type) - argsize; + tmp = fold_convert (result_type, + build_call_expr_loc (input_location, func, + 1, arg)); + leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type, + tmp, build_int_cst (result_type, s)); + } + else + { + /* We end up here if the argument type is larger than 'long long'. + We generate this code: + + if (x & (ULL_MAX << ULL_SIZE) != 0) + return clzll ((unsigned long long) (x >> ULLSIZE)); + else + return ULL_SIZE + clzll ((unsigned long long) x); + where ULL_MAX is the largest value that a ULL_MAX can hold + (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE + is the bit-size of the long long type (64 in this example). */ + tree ullsize, ullmax, tmp1, tmp2; + + ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE); + ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR, + long_long_unsigned_type_node, + build_int_cst (long_long_unsigned_type_node, + 0)); + + cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type, + fold_convert (arg_type, ullmax), ullsize); + cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, + arg, cond); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond, build_int_cst (arg_type, 0)); + + tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type, + arg, ullsize); + tmp1 = fold_convert (long_long_unsigned_type_node, tmp1); + tmp1 = fold_convert (result_type, + build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_CLZLL], + 1, tmp1)); + + tmp2 = fold_convert (long_long_unsigned_type_node, arg); + tmp2 = fold_convert (result_type, + build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_CLZLL], + 1, tmp2)); + tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type, + tmp2, ullsize); + + leadz = fold_build3_loc (input_location, COND_EXPR, result_type, + cond, tmp1, tmp2); + } /* Build BIT_SIZE. */ bit_size = build_int_cst (result_type, argsize); - cond = fold_build2 (EQ_EXPR, boolean_type_node, - arg, build_int_cst (arg_type, 0)); - se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + arg, build_int_cst (arg_type, 0)); + se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond, + bit_size, leadz); } + /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i) The conditional expression is necessary because the result of TRAILZ(0) @@ -3317,9 +3691,9 @@ gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr) } else { - gcc_assert (argsize == 128); + gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE); arg_type = gfc_build_uint_type (argsize); - func = gfor_fndecl_ctz128; + func = NULL_TREE; } /* Convert the actual argument twice: first, to the unsigned type of the @@ -3327,20 +3701,151 @@ gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr) function. But the return type is of the default INTEGER kind. */ arg = fold_convert (gfc_build_uint_type (argsize), arg); arg = fold_convert (arg_type, arg); + arg = gfc_evaluate_now (arg, &se->pre); result_type = gfc_get_int_type (gfc_default_integer_kind); /* Compute TRAILZ for the case i .ne. 0. */ - trailz = fold_convert (result_type, build_call_expr_loc (input_location, - func, 1, arg)); + if (func) + trailz = fold_convert (result_type, build_call_expr_loc (input_location, + func, 1, arg)); + else + { + /* We end up here if the argument type is larger than 'long long'. + We generate this code: + + if ((x & ULL_MAX) == 0) + return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE)); + else + return ctzll ((unsigned long long) x); + + where ULL_MAX is the largest value that a ULL_MAX can hold + (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE + is the bit-size of the long long type (64 in this example). */ + tree ullsize, ullmax, tmp1, tmp2; + + ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE); + ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR, + long_long_unsigned_type_node, + build_int_cst (long_long_unsigned_type_node, 0)); + + cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg, + fold_convert (arg_type, ullmax)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, cond, + build_int_cst (arg_type, 0)); + + tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type, + arg, ullsize); + tmp1 = fold_convert (long_long_unsigned_type_node, tmp1); + tmp1 = fold_convert (result_type, + build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_CTZLL], + 1, tmp1)); + tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type, + tmp1, ullsize); + + tmp2 = fold_convert (long_long_unsigned_type_node, arg); + tmp2 = fold_convert (result_type, + build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_CTZLL], + 1, tmp2)); + + trailz = fold_build3_loc (input_location, COND_EXPR, result_type, + cond, tmp1, tmp2); + } /* Build BIT_SIZE. */ bit_size = build_int_cst (result_type, argsize); - cond = fold_build2 (EQ_EXPR, boolean_type_node, - arg, build_int_cst (arg_type, 0)); - se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + arg, build_int_cst (arg_type, 0)); + se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond, + bit_size, trailz); +} + +/* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR; + for types larger than "long long", we call the long long built-in for + the lower and higher bits and combine the result. */ + +static void +gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity) +{ + tree arg; + tree arg_type; + tree result_type; + tree func; + int argsize; + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + argsize = TYPE_PRECISION (TREE_TYPE (arg)); + result_type = gfc_get_int_type (gfc_default_integer_kind); + + /* Which variant of the builtin should we call? */ + if (argsize <= INT_TYPE_SIZE) + { + arg_type = unsigned_type_node; + func = built_in_decls[parity ? BUILT_IN_PARITY : BUILT_IN_POPCOUNT]; + } + else if (argsize <= LONG_TYPE_SIZE) + { + arg_type = long_unsigned_type_node; + func = built_in_decls[parity ? BUILT_IN_PARITYL : BUILT_IN_POPCOUNTL]; + } + else if (argsize <= LONG_LONG_TYPE_SIZE) + { + arg_type = long_long_unsigned_type_node; + func = built_in_decls[parity ? BUILT_IN_PARITYLL : BUILT_IN_POPCOUNTLL]; + } + else + { + /* Our argument type is larger than 'long long', which mean none + of the POPCOUNT builtins covers it. We thus call the 'long long' + variant multiple times, and add the results. */ + tree utype, arg2, call1, call2; + + /* For now, we only cover the case where argsize is twice as large + as 'long long'. */ + gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE); + + func = built_in_decls[parity ? BUILT_IN_PARITYLL : BUILT_IN_POPCOUNTLL]; + + /* Convert it to an integer, and store into a variable. */ + utype = gfc_build_uint_type (argsize); + arg = fold_convert (utype, arg); + arg = gfc_evaluate_now (arg, &se->pre); + + /* Call the builtin twice. */ + call1 = build_call_expr_loc (input_location, func, 1, + fold_convert (long_long_unsigned_type_node, + arg)); + + arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg, + build_int_cst (utype, LONG_LONG_TYPE_SIZE)); + call2 = build_call_expr_loc (input_location, func, 1, + fold_convert (long_long_unsigned_type_node, + arg2)); + + /* Combine the results. */ + if (parity) + se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type, + call1, call2); + else + se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type, + call1, call2); + + return; + } + + /* Convert the actual argument twice: first, to the unsigned type of the + same size; then, to the proper argument type for the built-in + function. */ + arg = fold_convert (gfc_build_uint_type (argsize), arg); + arg = fold_convert (arg_type, arg); + + se->expr = fold_convert (result_type, + build_call_expr_loc (input_location, func, 1, arg)); } + /* Process an intrinsic with unspecified argument-types that has an optional argument (which could be of type character), e.g. EOSHIFT. For those, we need to append the string length of the optional argument if it is not @@ -3358,7 +3863,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; @@ -3382,13 +3887,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. */ @@ -3500,7 +4006,7 @@ gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr, tree *args; unsigned int num_args; - args = (tree *) alloca (sizeof (tree) * 5); + args = XALLOCAVEC (tree, 5); /* Get number of arguments; characters count double due to the string length argument. Kind= is not passed to the library @@ -3535,7 +4041,7 @@ gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_function_args (se, expr, args, 2); gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1]))); pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind); - args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]); + args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]); type = gfc_typenode_for_spec (&expr->ts); se->expr = build_fold_indirect_ref_loc (input_location, @@ -3568,8 +4074,9 @@ gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value) tree arg; gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - se->expr = fold_build2 (EQ_EXPR, gfc_typenode_for_spec (&expr->ts), - arg, build_int_cst (TREE_TYPE (arg), value)); + se->expr = fold_build2_loc (input_location, EQ_EXPR, + gfc_typenode_for_spec (&expr->ts), + arg, build_int_cst (TREE_TYPE (arg), value)); } @@ -3588,7 +4095,7 @@ gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr) unsigned int num_args; num_args = gfc_intrinsic_argument_list_length (expr); - args = (tree *) alloca (sizeof (tree) * num_args); + args = XALLOCAVEC (tree, num_args); gfc_conv_intrinsic_function_args (se, expr, args, num_args); if (expr->ts.type != BT_CHARACTER) @@ -3613,41 +4120,103 @@ gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr) se->string_length = len; } type = TREE_TYPE (tsource); - se->expr = fold_build3 (COND_EXPR, type, mask, tsource, - fold_convert (type, fsource)); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource, + fold_convert (type, fsource)); } -/* FRACTION (s) is translated into frexp (s, &dummy_int). */ +/* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */ + static void -gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr) +gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr) +{ + tree args[3], mask, type; + + gfc_conv_intrinsic_function_args (se, expr, args, 3); + mask = gfc_evaluate_now (args[2], &se->pre); + + type = TREE_TYPE (args[0]); + gcc_assert (TREE_TYPE (args[1]) == type); + gcc_assert (TREE_TYPE (mask) == type); + + args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask); + args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1], + fold_build1_loc (input_location, BIT_NOT_EXPR, + type, mask)); + se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type, + args[0], args[1]); +} + + +/* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n) + MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */ + +static void +gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left) { - tree arg, type, tmp; - int frexp; + tree arg, allones, type, utype, res, cond, bitsize; + int i; + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + arg = gfc_evaluate_now (arg, &se->pre); + + type = gfc_get_int_type (expr->ts.kind); + utype = unsigned_type_for (type); + + i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false); + bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size); - switch (expr->ts.kind) + allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, + build_int_cst (utype, 0)); + + if (left) { - case 4: - frexp = BUILT_IN_FREXPF; - break; - case 8: - frexp = BUILT_IN_FREXP; - break; - case 10: - case 16: - frexp = BUILT_IN_FREXPL; - break; - default: - gcc_unreachable (); + /* Left-justified mask. */ + res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg), + bitsize, arg); + res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones, + fold_convert (utype, res)); + + /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly + smaller than type width. */ + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg, + build_int_cst (TREE_TYPE (arg), 0)); + res = fold_build3_loc (input_location, COND_EXPR, utype, cond, + build_int_cst (utype, 0), res); + } + else + { + /* Right-justified mask. */ + res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones, + fold_convert (utype, arg)); + res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res); + + /* Special case agr == bit_size, because SHIFT_EXPR wants a shift + strictly smaller than type width. */ + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + arg, bitsize); + res = fold_build3_loc (input_location, COND_EXPR, utype, + cond, allones, res); } + se->expr = fold_convert (type, res); +} + + +/* FRACTION (s) is translated into frexp (s, &dummy_int). */ +static void +gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr) +{ + tree arg, type, tmp, frexp; + + frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); + type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, &arg, 1); tmp = gfc_create_var (integer_type_node, NULL); - se->expr = build_call_expr_loc (input_location, - built_in_decls[frexp], 2, - fold_convert (type, arg), - gfc_build_addr_expr (NULL_TREE, tmp)); + se->expr = build_call_expr_loc (input_location, frexp, 2, + fold_convert (type, arg), + gfc_build_addr_expr (NULL_TREE, tmp)); se->expr = fold_convert (type, se->expr); } @@ -3659,41 +4228,19 @@ gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr) { - tree args[2], type, tmp; - int nextafter, copysign, huge_val; + tree args[2], type, tmp, nextafter, copysign, huge_val; - switch (expr->ts.kind) - { - case 4: - nextafter = BUILT_IN_NEXTAFTERF; - copysign = BUILT_IN_COPYSIGNF; - huge_val = BUILT_IN_HUGE_VALF; - break; - case 8: - nextafter = BUILT_IN_NEXTAFTER; - copysign = BUILT_IN_COPYSIGN; - huge_val = BUILT_IN_HUGE_VAL; - break; - case 10: - case 16: - nextafter = BUILT_IN_NEXTAFTERL; - copysign = BUILT_IN_COPYSIGNL; - huge_val = BUILT_IN_HUGE_VALL; - break; - default: - gcc_unreachable (); - } + nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind); + copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind); type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, args, 2); - tmp = build_call_expr_loc (input_location, - built_in_decls[copysign], 2, - build_call_expr_loc (input_location, - built_in_decls[huge_val], 0), - fold_convert (type, args[1])); - se->expr = build_call_expr_loc (input_location, - built_in_decls[nextafter], 2, - fold_convert (type, args[0]), tmp); + + huge_val = gfc_build_inf_or_huge (type, expr->ts.kind); + tmp = build_call_expr_loc (input_location, copysign, 2, huge_val, + fold_convert (type, args[1])); + se->expr = build_call_expr_loc (input_location, nextafter, 2, + fold_convert (type, args[0]), tmp); se->expr = fold_convert (type, se->expr); } @@ -3719,8 +4266,8 @@ static void gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) { tree arg, type, prec, emin, tiny, res, e; - tree cond, tmp; - int frexp, scalbn, k; + tree cond, tmp, frexp, scalbn; + int k; stmtblock_t block; k = gfc_validate_kind (BT_REAL, expr->ts.kind, false); @@ -3728,24 +4275,8 @@ gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1); tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0); - switch (expr->ts.kind) - { - case 4: - frexp = BUILT_IN_FREXPF; - scalbn = BUILT_IN_SCALBNF; - break; - case 8: - frexp = BUILT_IN_FREXP; - scalbn = BUILT_IN_SCALBN; - break; - case 10: - case 16: - frexp = BUILT_IN_FREXPL; - scalbn = BUILT_IN_SCALBNL; - break; - default: - gcc_unreachable (); - } + frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); + scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); gfc_conv_intrinsic_function_args (se, expr, &arg, 1); arg = gfc_evaluate_now (arg, &se->pre); @@ -3757,23 +4288,22 @@ gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) /* Build the block for s /= 0. */ gfc_start_block (&block); - tmp = build_call_expr_loc (input_location, - built_in_decls[frexp], 2, arg, - gfc_build_addr_expr (NULL_TREE, e)); + tmp = build_call_expr_loc (input_location, frexp, 2, arg, + gfc_build_addr_expr (NULL_TREE, e)); gfc_add_expr_to_block (&block, tmp); - tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec); - gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node, - tmp, emin)); + tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e, + prec); + gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR, + integer_type_node, tmp, emin)); - tmp = build_call_expr_loc (input_location, - built_in_decls[scalbn], 2, + tmp = build_call_expr_loc (input_location, scalbn, 2, build_real_from_int_cst (type, integer_one_node), e); gfc_add_modify (&block, res, tmp); /* Finish by building the IF statement. */ - cond = fold_build2 (EQ_EXPR, boolean_type_node, arg, - build_real_from_int_cst (type, integer_zero_node)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg, + build_real_from_int_cst (type, integer_zero_node)); tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny), gfc_finish_block (&block)); @@ -3798,33 +4328,16 @@ gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr) { - tree arg, type, e, x, cond, stmt, tmp; - int frexp, scalbn, fabs, prec, k; + tree arg, type, e, x, cond, stmt, tmp, frexp, scalbn, fabs; + int prec, k; stmtblock_t block; k = gfc_validate_kind (BT_REAL, expr->ts.kind, false); prec = gfc_real_kinds[k].digits; - switch (expr->ts.kind) - { - case 4: - frexp = BUILT_IN_FREXPF; - scalbn = BUILT_IN_SCALBNF; - fabs = BUILT_IN_FABSF; - break; - case 8: - frexp = BUILT_IN_FREXP; - scalbn = BUILT_IN_SCALBN; - fabs = BUILT_IN_FABS; - break; - case 10: - case 16: - frexp = BUILT_IN_FREXPL; - scalbn = BUILT_IN_SCALBNL; - fabs = BUILT_IN_FABSL; - break; - default: - gcc_unreachable (); - } + + frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); + scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); + fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind); type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, &arg, 1); @@ -3833,25 +4346,22 @@ gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr) e = gfc_create_var (integer_type_node, NULL); x = gfc_create_var (type, NULL); gfc_add_modify (&se->pre, x, - build_call_expr_loc (input_location, - built_in_decls[fabs], 1, arg)); + build_call_expr_loc (input_location, fabs, 1, arg)); gfc_start_block (&block); - tmp = build_call_expr_loc (input_location, - built_in_decls[frexp], 2, arg, - gfc_build_addr_expr (NULL_TREE, e)); + tmp = build_call_expr_loc (input_location, frexp, 2, arg, + gfc_build_addr_expr (NULL_TREE, e)); gfc_add_expr_to_block (&block, tmp); - tmp = fold_build2 (MINUS_EXPR, integer_type_node, - build_int_cst (NULL_TREE, prec), e); - tmp = build_call_expr_loc (input_location, - built_in_decls[scalbn], 2, x, tmp); + tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, + build_int_cst (NULL_TREE, prec), e); + tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp); gfc_add_modify (&block, x, tmp); stmt = gfc_finish_block (&block); - cond = fold_build2 (NE_EXPR, boolean_type_node, x, - build_real_from_int_cst (type, integer_zero_node)); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, x, + build_real_from_int_cst (type, integer_zero_node)); tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->pre, tmp); @@ -3863,31 +4373,15 @@ gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr) { - tree args[2], type; - int scalbn; + tree args[2], type, scalbn; - switch (expr->ts.kind) - { - case 4: - scalbn = BUILT_IN_SCALBNF; - break; - case 8: - scalbn = BUILT_IN_SCALBN; - break; - case 10: - case 16: - scalbn = BUILT_IN_SCALBNL; - break; - default: - gcc_unreachable (); - } + scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, args, 2); - se->expr = build_call_expr_loc (input_location, - built_in_decls[scalbn], 2, - fold_convert (type, args[0]), - fold_convert (integer_type_node, args[1])); + se->expr = build_call_expr_loc (input_location, scalbn, 2, + fold_convert (type, args[0]), + fold_convert (integer_type_node, args[1])); se->expr = fold_convert (type, se->expr); } @@ -3897,39 +4391,20 @@ gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr) { - tree args[2], type, tmp; - int frexp, scalbn; + tree args[2], type, tmp, frexp, scalbn; - switch (expr->ts.kind) - { - case 4: - frexp = BUILT_IN_FREXPF; - scalbn = BUILT_IN_SCALBNF; - break; - case 8: - frexp = BUILT_IN_FREXP; - scalbn = BUILT_IN_SCALBN; - break; - case 10: - case 16: - frexp = BUILT_IN_FREXPL; - scalbn = BUILT_IN_SCALBNL; - break; - default: - gcc_unreachable (); - } + frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); + scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, args, 2); tmp = gfc_create_var (integer_type_node, NULL); - tmp = build_call_expr_loc (input_location, - built_in_decls[frexp], 2, - fold_convert (type, args[0]), - gfc_build_addr_expr (NULL_TREE, tmp)); - se->expr = build_call_expr_loc (input_location, - built_in_decls[scalbn], 2, tmp, - fold_convert (integer_type_node, args[1])); + tmp = build_call_expr_loc (input_location, frexp, 2, + fold_convert (type, args[0]), + gfc_build_addr_expr (NULL_TREE, tmp)); + se->expr = build_call_expr_loc (input_location, scalbn, 2, tmp, + fold_convert (integer_type_node, args[1])); se->expr = fold_convert (type, se->expr); } @@ -3987,17 +4462,18 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) argse.data_not_needed = 1; gfc_conv_expr (&argse, actual->expr); gfc_add_block_to_block (&se->pre, &argse.pre); - tmp = fold_build2 (NE_EXPR, boolean_type_node, - argse.expr, null_pointer_node); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + argse.expr, null_pointer_node); tmp = gfc_evaluate_now (tmp, &se->pre); - se->expr = fold_build3 (COND_EXPR, pvoid_type_node, - tmp, fncall1, fncall0); + se->expr = fold_build3_loc (input_location, COND_EXPR, + pvoid_type_node, tmp, fncall1, fncall0); } else { se->expr = NULL_TREE; - argse.expr = fold_build2 (MINUS_EXPR, gfc_array_index_type, - argse.expr, gfc_index_one_node); + argse.expr = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + argse.expr, gfc_index_one_node); } } else if (expr->value.function.actual->expr->rank == 1) @@ -4016,12 +4492,14 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) arg1); ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr); lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr); - se->expr = fold_build2 (MINUS_EXPR, gfc_array_index_type, - ubound, lbound); - se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, se->expr, - gfc_index_one_node); - se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr, - gfc_index_zero_node); + se->expr = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, ubound, lbound); + se->expr = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + se->expr, gfc_index_one_node); + se->expr = fold_build2_loc (input_location, MAX_EXPR, + gfc_array_index_type, se->expr, + gfc_index_zero_node); } type = gfc_typenode_for_spec (&expr->ts); @@ -4042,8 +4520,9 @@ size_of_string_in_bytes (int kind, tree string_length) bytesize = build_int_cst (gfc_array_index_type, gfc_character_kinds[i].bit_size / 8); - return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize, - fold_convert (gfc_array_index_type, string_length)); + return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + bytesize, + fold_convert (gfc_array_index_type, string_length)); } @@ -4067,6 +4546,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, @@ -4101,12 +4583,12 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) idx = gfc_rank_cst[n]; lower = gfc_conv_descriptor_lbound_get (argse.expr, idx); upper = gfc_conv_descriptor_ubound_get (argse.expr, idx); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - upper, lower); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node); - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - tmp, source_bytes); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, upper, lower); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, gfc_index_one_node); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, source_bytes); gfc_add_modify (&argse.pre, source_bytes, tmp); } se->expr = source_bytes; @@ -4116,6 +4598,57 @@ 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_loc (input_location, MULT_EXPR, result_type, tmp, + eight.expr); + gfc_add_block_to_block (&se->pre, &argse.pre); +} + + /* Intrinsic string comparison functions. */ static void @@ -4127,9 +4660,11 @@ 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); - se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr, - build_int_cst (TREE_TYPE (se->expr), 0)); + expr->value.function.actual->expr->ts.kind, + op); + se->expr = fold_build2_loc (input_location, op, + gfc_typenode_for_spec (&expr->ts), se->expr, + build_int_cst (TREE_TYPE (se->expr), 0)); } /* Generate a call to the adjustl/adjustr library function. */ @@ -4267,7 +4802,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) /* Clean up if it was repacked. */ gfc_init_block (&block); tmp = gfc_conv_array_data (argse.expr); - tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + source, tmp); tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); @@ -4293,13 +4829,14 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) gfc_add_modify (&argse.pre, source_bytes, tmp); lower = gfc_conv_descriptor_lbound_get (argse.expr, idx); upper = gfc_conv_descriptor_ubound_get (argse.expr, idx); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - upper, lower); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, upper, lower); gfc_add_modify (&argse.pre, extent, tmp); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - extent, gfc_index_one_node); - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - tmp, source_bytes); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, extent, + gfc_index_one_node); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, source_bytes); } } @@ -4377,15 +4914,16 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) size_bytes = gfc_create_var (gfc_array_index_type, NULL); if (tmp != NULL_TREE) - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - tmp, dest_word_len); + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + tmp, dest_word_len); else tmp = source_bytes; gfc_add_modify (&se->pre, size_bytes, tmp); gfc_add_modify (&se->pre, size_words, - fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type, - size_bytes, dest_word_len)); + fold_build2_loc (input_location, CEIL_DIV_EXPR, + gfc_array_index_type, + size_bytes, dest_word_len)); /* Evaluate the bounds of the result. If the loop range exists, we have to check if it is too large. If so, we modify loop->to be consistent @@ -4394,25 +4932,26 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) n = se->loop->order[0]; if (se->loop->to[n] != NULL_TREE) { - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - se->loop->to[n], se->loop->from[n]); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node); - tmp = fold_build2 (MIN_EXPR, gfc_array_index_type, + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + se->loop->to[n], se->loop->from[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type, tmp, size_words); gfc_add_modify (&se->pre, size_words, tmp); gfc_add_modify (&se->pre, size_bytes, - fold_build2 (MULT_EXPR, gfc_array_index_type, - size_words, dest_word_len)); - upper = fold_build2 (PLUS_EXPR, gfc_array_index_type, - size_words, se->loop->from[n]); - upper = fold_build2 (MINUS_EXPR, gfc_array_index_type, - upper, gfc_index_one_node); + fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + size_words, dest_word_len)); + upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size_words, se->loop->from[n]); + upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + upper, gfc_index_one_node); } else { - upper = fold_build2 (MINUS_EXPR, gfc_array_index_type, - size_words, gfc_index_one_node); + upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size_words, gfc_index_one_node); se->loop->from[n] = gfc_index_zero_node; } @@ -4434,22 +4973,23 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) 3, tmp, fold_convert (pvoid_type_node, source), - fold_build2 (MIN_EXPR, gfc_array_index_type, - size_bytes, source_bytes)); + fold_build2_loc (input_location, MIN_EXPR, + gfc_array_index_type, + size_bytes, source_bytes)); gfc_add_expr_to_block (&se->pre, tmp); se->expr = info->descriptor; if (expr->ts.type == BT_CHARACTER) - se->string_length = dest_word_len; + se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len); return; /* Deal with scalar results. */ scalar_transfer: - extent = fold_build2 (MIN_EXPR, gfc_array_index_type, - dest_word_len, source_bytes); - extent = fold_build2 (MAX_EXPR, gfc_array_index_type, - extent, gfc_index_zero_node); + extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type, + dest_word_len, source_bytes); + extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, + extent, gfc_index_zero_node); if (expr->ts.type == BT_CHARACTER) { @@ -4482,8 +5022,8 @@ scalar_transfer: indirect = gfc_finish_block (&block); /* Wrap it up with the condition. */ - tmp = fold_build2 (LE_EXPR, boolean_type_node, - dest_word_len, source_bytes); + tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, + dest_word_len, source_bytes); tmp = build3_v (COND_EXPR, tmp, direct, indirect); gfc_add_expr_to_block (&se->pre, tmp); @@ -4529,6 +5069,8 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr) { /* Allocatable scalar. */ arg1se.want_pointer = 1; + if (arg1->expr->ts.type == BT_CLASS) + gfc_add_component_ref (arg1->expr, "$data"); gfc_conv_expr (&arg1se, arg1->expr); tmp = arg1se.expr; } @@ -4540,8 +5082,8 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr) tmp = gfc_conv_descriptor_data_get (arg1se.expr); } - tmp = fold_build2 (NE_EXPR, boolean_type_node, - tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, + fold_convert (TREE_TYPE (tmp), null_pointer_node)); se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); } @@ -4591,20 +5133,23 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) } gfc_add_block_to_block (&se->pre, &arg1se.pre); gfc_add_block_to_block (&se->post, &arg1se.post); - tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp2, - fold_convert (TREE_TYPE (tmp2), null_pointer_node)); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2, + fold_convert (TREE_TYPE (tmp2), null_pointer_node)); se->expr = tmp; } else { /* An optional target. */ + if (arg2->expr->ts.type == BT_CLASS) + gfc_add_component_ref (arg2->expr, "$data"); ss2 = gfc_walk_expr (arg2->expr); nonzero_charlen = NULL_TREE; if (arg1->expr->ts.type == BT_CHARACTER) - nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node, - arg1->expr->ts.u.cl->backend_decl, - integer_zero_node); + nonzero_charlen = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + arg1->expr->ts.u.cl->backend_decl, + integer_zero_node); if (ss1 == gfc_ss_terminator) { @@ -4616,12 +5161,12 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) gfc_conv_expr (&arg2se, arg2->expr); gfc_add_block_to_block (&se->pre, &arg1se.pre); gfc_add_block_to_block (&se->post, &arg1se.post); - tmp = fold_build2 (EQ_EXPR, boolean_type_node, - arg1se.expr, arg2se.expr); - tmp2 = fold_build2 (NE_EXPR, boolean_type_node, - arg1se.expr, null_pointer_node); - se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - tmp, tmp2); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + arg1se.expr, arg2se.expr); + tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + arg1se.expr, null_pointer_node); + se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, tmp, tmp2); } else { @@ -4631,8 +5176,9 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) gfc_conv_expr_lhs (&arg1se, arg1->expr); tmp = gfc_conv_descriptor_stride_get (arg1se.expr, gfc_rank_cst[arg1->expr->rank - 1]); - nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp, - build_int_cst (TREE_TYPE (tmp), 0)); + nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); /* A pointer to an array, call library function _gfor_associated. */ gcc_assert (ss2 != gfc_ss_terminator); @@ -4647,15 +5193,17 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) gfor_fndecl_associated, 2, arg1se.expr, arg2se.expr); se->expr = convert (boolean_type_node, se->expr); - se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - se->expr, nonzero_arraylen); + se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, se->expr, + nonzero_arraylen); } /* If target is present zero character length pointers cannot be associated. */ if (nonzero_charlen != NULL_TREE) - se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - se->expr, nonzero_charlen); + se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, + se->expr, nonzero_charlen); } se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); @@ -4684,7 +5232,8 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) gfc_add_component_ref (a, "$hash"); } else if (a->ts.type == BT_DERIVED) - a = gfc_int_expr (a->ts.u.derived->hash_value); + a = gfc_get_int_expr (gfc_default_integer_kind, NULL, + a->ts.u.derived->hash_value); if (b->ts.type == BT_CLASS) { @@ -4692,13 +5241,14 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) gfc_add_component_ref (b, "$hash"); } else if (b->ts.type == BT_DERIVED) - b = gfc_int_expr (b->ts.u.derived->hash_value); + b = gfc_get_int_expr (gfc_default_integer_kind, NULL, + b->ts.u.derived->hash_value); gfc_conv_expr (&se1, a); gfc_conv_expr (&se2, b); - tmp = fold_build2 (EQ_EXPR, boolean_type_node, - se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr)); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr)); se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); } @@ -4744,10 +5294,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); @@ -4772,13 +5322,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); } @@ -4799,11 +5349,11 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) unsigned int num_args; num_args = gfc_intrinsic_argument_list_length (expr) + 2; - args = (tree *) alloca (sizeof (tree) * num_args); + args = XALLOCAVEC (tree, num_args); var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr"); addr = gfc_build_addr_expr (ppvoid_type_node, var); - len = gfc_create_var (gfc_get_int_type (4), "len"); + len = gfc_create_var (gfc_charlen_type_node, "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); args[0] = gfc_build_addr_expr (NULL_TREE, len); @@ -4823,8 +5373,8 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ - cond = fold_build2 (GT_EXPR, boolean_type_node, - len, build_int_cst (TREE_TYPE (len), 0)); + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + len, build_int_cst (TREE_TYPE (len), 0)); tmp = gfc_call_free (var); tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->post, tmp); @@ -4857,8 +5407,8 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) ncopies_type = TREE_TYPE (ncopies); /* Check that NCOPIES is not negative. */ - cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies, - build_int_cst (ncopies_type, 0)); + cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, ncopies, + build_int_cst (ncopies_type, 0)); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, "Argument NCOPIES of REPEAT intrinsic is negative " "(its value is %lld)", @@ -4867,10 +5417,10 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) /* If the source length is zero, any non negative value of NCOPIES is valid, and nothing happens. */ n = gfc_create_var (ncopies_type, "ncopies"); - cond = fold_build2 (EQ_EXPR, boolean_type_node, slen, - build_int_cst (size_type_node, 0)); - tmp = fold_build3 (COND_EXPR, ncopies_type, cond, - build_int_cst (ncopies_type, 0), ncopies); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen, + build_int_cst (size_type_node, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond, + build_int_cst (ncopies_type, 0), ncopies); gfc_add_modify (&se->pre, n, tmp); ncopies = n; @@ -4880,24 +5430,24 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) case to avoid the division by zero. */ i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind); - max = fold_build2 (TRUNC_DIV_EXPR, size_type_node, - fold_convert (size_type_node, max), slen); + max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node, + fold_convert (size_type_node, max), slen); largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type) ? size_type_node : ncopies_type; - cond = fold_build2 (GT_EXPR, boolean_type_node, - fold_convert (largest, ncopies), - fold_convert (largest, max)); - tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen, - build_int_cst (size_type_node, 0)); - cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node, - cond); + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + fold_convert (largest, ncopies), + fold_convert (largest, max)); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen, + build_int_cst (size_type_node, 0)); + cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp, + boolean_false_node, cond); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, "Argument NCOPIES of REPEAT intrinsic is too large"); /* Compute the destination length. */ - dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node, - fold_convert (gfc_charlen_type_node, slen), - fold_convert (gfc_charlen_type_node, ncopies)); + dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node, + fold_convert (gfc_charlen_type_node, slen), + fold_convert (gfc_charlen_type_node, ncopies)); type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl); dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen); @@ -4913,31 +5463,34 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) gfc_start_block (&body); /* Exit the loop if count >= ncopies. */ - cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies); + cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count, + ncopies); tmp = build1_v (GOTO_EXPR, exit_label); TREE_USED (exit_label) = 1; - tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, - build_empty_stmt (input_location)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, + build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); /* Call memmove (dest + (i*slen*size), src, slen*size). */ - tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node, - fold_convert (gfc_charlen_type_node, slen), - fold_convert (gfc_charlen_type_node, count)); - tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node, - tmp, fold_convert (gfc_charlen_type_node, size)); - tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node, - fold_convert (pvoid_type_node, dest), - fold_convert (sizetype, tmp)); + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node, + fold_convert (gfc_charlen_type_node, slen), + fold_convert (gfc_charlen_type_node, count)); + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node, + tmp, fold_convert (gfc_charlen_type_node, size)); + tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR, pvoid_type_node, + fold_convert (pvoid_type_node, dest), + fold_convert (sizetype, tmp)); tmp = build_call_expr_loc (input_location, - built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src, - fold_build2 (MULT_EXPR, size_type_node, slen, - fold_convert (size_type_node, size))); + built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src, + fold_build2_loc (input_location, MULT_EXPR, + size_type_node, slen, + fold_convert (size_type_node, + size))); gfc_add_expr_to_block (&body, tmp); /* Increment count. */ - tmp = fold_build2 (PLUS_EXPR, ncopies_type, - count, build_int_cst (TREE_TYPE (count), 1)); + tmp = fold_build2_loc (input_location, PLUS_EXPR, ncopies_type, + count, build_int_cst (TREE_TYPE (count), 1)); gfc_add_modify (&body, count, tmp); /* Build the loop. */ @@ -5020,7 +5573,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) name = &expr->value.function.name[2]; - if (expr->rank > 0 && !expr->inline_noncopying_intrinsic) + if (expr->rank > 0) { lib = gfc_is_intrinsic_libcall (expr); if (lib != 0) @@ -5166,6 +5719,22 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_btest (se, expr); break; + case GFC_ISYM_BGE: + gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR); + break; + + case GFC_ISYM_BGT: + gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR); + break; + + case GFC_ISYM_BLE: + gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR); + break; + + case GFC_ISYM_BLT: + gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR); + break; + case GFC_ISYM_ACHAR: case GFC_ISYM_CHAR: gfc_conv_intrinsic_char (se, expr); @@ -5243,6 +5812,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_dprod (se, expr); break; + case GFC_ISYM_DSHIFTL: + gfc_conv_intrinsic_dshift (se, expr, true); + break; + + case GFC_ISYM_DSHIFTR: + gfc_conv_intrinsic_dshift (se, expr, false); + break; + case GFC_ISYM_FDATE: gfc_conv_intrinsic_fdate (se, expr); break; @@ -5251,10 +5828,18 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_fraction (se, expr); break; + case GFC_ISYM_IALL: + gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false); + break; + case GFC_ISYM_IAND: gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR); break; + case GFC_ISYM_IANY: + gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false); + break; + case GFC_ISYM_IBCLR: gfc_conv_intrinsic_singlebitop (se, expr, 0); break; @@ -5297,6 +5882,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR); break; + case GFC_ISYM_IPARITY: + gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false); + break; + case GFC_ISYM_IS_IOSTAT_END: gfc_conv_has_intvalue (se, expr, LIBERROR_END); break; @@ -5310,11 +5899,23 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_LSHIFT: - gfc_conv_intrinsic_rlshift (se, expr, 0); + gfc_conv_intrinsic_shift (se, expr, false, false); break; case GFC_ISYM_RSHIFT: - gfc_conv_intrinsic_rlshift (se, expr, 1); + gfc_conv_intrinsic_shift (se, expr, true, true); + break; + + case GFC_ISYM_SHIFTA: + gfc_conv_intrinsic_shift (se, expr, true, true); + break; + + case GFC_ISYM_SHIFTL: + gfc_conv_intrinsic_shift (se, expr, false, false); + break; + + case GFC_ISYM_SHIFTR: + gfc_conv_intrinsic_shift (se, expr, true, false); break; case GFC_ISYM_ISHFT: @@ -5333,18 +5934,22 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_trailz (se, expr); break; + case GFC_ISYM_POPCNT: + gfc_conv_intrinsic_popcnt_poppar (se, expr, 0); + break; + + case GFC_ISYM_POPPAR: + gfc_conv_intrinsic_popcnt_poppar (se, expr, 1); + break; + case GFC_ISYM_LBOUND: gfc_conv_intrinsic_bound (se, expr, 0); break; case GFC_ISYM_TRANSPOSE: - if (se->ss && se->ss->useflags) - { - gfc_conv_tmp_array_ref (se); - gfc_advance_se_ss_chain (se); - } - else - gfc_conv_array_transpose (se, expr->value.function.actual->expr); + /* The scalarizer has already been set up for reversed dimension access + order ; now we just get the argument value normally. */ + gfc_conv_expr (se, expr->value.function.actual->expr); break; case GFC_ISYM_LEN: @@ -5371,6 +5976,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR); break; + case GFC_ISYM_MASKL: + gfc_conv_intrinsic_mask (se, expr, 1); + break; + + case GFC_ISYM_MASKR: + gfc_conv_intrinsic_mask (se, expr, 0); + break; + case GFC_ISYM_MAX: if (expr->ts.type == BT_CHARACTER) gfc_conv_intrinsic_minmax_char (se, expr, 1); @@ -5390,6 +6003,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_merge (se, expr); break; + case GFC_ISYM_MERGE_BITS: + gfc_conv_intrinsic_merge_bits (se, expr); + break; + case GFC_ISYM_MIN: if (expr->ts.type == BT_CHARACTER) gfc_conv_intrinsic_minmax_char (se, expr, -1); @@ -5409,6 +6026,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_nearest (se, expr); break; + case GFC_ISYM_NORM2: + gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true); + break; + case GFC_ISYM_NOT: gfc_conv_intrinsic_not (se, expr); break; @@ -5417,12 +6038,16 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR); break; + case GFC_ISYM_PARITY: + gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false); + break; + case GFC_ISYM_PRESENT: gfc_conv_intrinsic_present (se, expr); break; case GFC_ISYM_PRODUCT: - gfc_conv_intrinsic_arith (se, expr, MULT_EXPR); + gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false); break; case GFC_ISYM_RRSPACING: @@ -5446,15 +6071,20 @@ 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; case GFC_ISYM_SUM: - gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR); + gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false); break; case GFC_ISYM_TRANSFER: @@ -5506,6 +6136,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_IERRNO: case GFC_ISYM_IRAND: case GFC_ISYM_ISATTY: + case GFC_ISYM_JN2: case GFC_ISYM_LINK: case GFC_ISYM_LSTAT: case GFC_ISYM_MALLOC: @@ -5524,6 +6155,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_TIME8: case GFC_ISYM_UMASK: case GFC_ISYM_UNLINK: + case GFC_ISYM_YN2: gfc_conv_intrinsic_funcall (se, expr); break; @@ -5542,6 +6174,64 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) } +static gfc_ss * +walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr) +{ + gfc_ss *arg_ss, *tmp_ss; + gfc_actual_arglist *arg; + + arg = expr->value.function.actual; + + gcc_assert (arg->expr); + + arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr); + gcc_assert (arg_ss != gfc_ss_terminator); + + for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next) + { + if (tmp_ss->type != GFC_SS_SCALAR + && tmp_ss->type != GFC_SS_REFERENCE) + { + int tmp_dim; + gfc_ss_info *info; + + info = &tmp_ss->data.info; + gcc_assert (info->dimen == 2); + + /* We just invert dimensions. */ + tmp_dim = info->dim[0]; + info->dim[0] = info->dim[1]; + info->dim[1] = tmp_dim; + } + + /* Stop when tmp_ss points to the last valid element of the chain... */ + if (tmp_ss->next == gfc_ss_terminator) + break; + } + + /* ... so that we can attach the rest of the chain to it. */ + tmp_ss->next = ss; + + return arg_ss; +} + + +static gfc_ss * +walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr) +{ + + switch (expr->value.function.isym->id) + { + case GFC_ISYM_TRANSPOSE: + return walk_inline_intrinsic_transpose (ss, expr); + + default: + gcc_unreachable (); + } + gcc_unreachable (); +} + + /* This generates code to execute before entering the scalarization loop. Currently does nothing. */ @@ -5588,6 +6278,7 @@ static gfc_ss * gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr) { gfc_ss *newss; + int n; gcc_assert (expr->rank > 0); @@ -5596,11 +6287,33 @@ gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr) newss->expr = expr; newss->next = ss; newss->data.info.dimen = expr->rank; + for (n = 0; n < newss->data.info.dimen; n++) + newss->data.info.dim[n] = n; return newss; } +/* Return whether the function call expression EXPR will be expanded + inline by gfc_conv_intrinsic_function. */ + +bool +gfc_inline_intrinsic_function_p (gfc_expr *expr) +{ + if (!expr->value.function.isym) + return false; + + switch (expr->value.function.isym->id) + { + case GFC_ISYM_TRANSPOSE: + return true; + + default: + return false; + } +} + + /* Returns nonzero if the specified intrinsic function call maps directly to an external library call. Should only be used for functions that return arrays. */ @@ -5611,21 +6324,30 @@ gfc_is_intrinsic_libcall (gfc_expr * expr) gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym); gcc_assert (expr->rank > 0); + if (gfc_inline_intrinsic_function_p (expr)) + return 0; + switch (expr->value.function.isym->id) { case GFC_ISYM_ALL: case GFC_ISYM_ANY: case GFC_ISYM_COUNT: + case GFC_ISYM_JN2: + case GFC_ISYM_IANY: + case GFC_ISYM_IALL: + case GFC_ISYM_IPARITY: case GFC_ISYM_MATMUL: case GFC_ISYM_MAXLOC: case GFC_ISYM_MAXVAL: case GFC_ISYM_MINLOC: case GFC_ISYM_MINVAL: + case GFC_ISYM_NORM2: + case GFC_ISYM_PARITY: case GFC_ISYM_PRODUCT: case GFC_ISYM_SUM: case GFC_ISYM_SHAPE: case GFC_ISYM_SPREAD: - case GFC_ISYM_TRANSPOSE: + case GFC_ISYM_YN2: /* Ignore absent optional parameters. */ return 1; @@ -5650,11 +6372,15 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, gcc_assert (isym); if (isym->elemental) - return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR); + return gfc_walk_elemental_function_args (ss, expr->value.function.actual, + GFC_SS_SCALAR); if (expr->rank == 0) return ss; + if (gfc_inline_intrinsic_function_p (expr)) + return walk_inline_intrinsic_function (ss, expr); + if (gfc_is_intrinsic_libcall (expr)) return gfc_walk_intrinsic_libfunc (ss, expr); @@ -5676,4 +6402,42 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, } } + +tree +gfc_conv_intrinsic_move_alloc (gfc_code *code) +{ + if (code->ext.actual->expr->rank == 0) + { + /* Scalar arguments: Generate pointer assignments. */ + gfc_expr *from, *to; + stmtblock_t block; + tree tmp; + + from = code->ext.actual->expr; + to = code->ext.actual->next->expr; + + gfc_start_block (&block); + + if (to->ts.type == BT_CLASS) + tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN); + else + tmp = gfc_trans_pointer_assignment (to, from); + gfc_add_expr_to_block (&block, tmp); + + if (from->ts.type == BT_CLASS) + tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL), + EXEC_POINTER_ASSIGN); + else + tmp = gfc_trans_pointer_assignment (from, + gfc_get_null_expr (NULL)); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); + } + else + /* Array arguments: Generate library code. */ + return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false); +} + + #include "gt-fortran-trans-intrinsic.h" diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 96671f3819c..6d4cba237e7 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -24,10 +24,8 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "gimple.h" #include "ggc.h" -#include "toplev.h" -#include "real.h" +#include "diagnostic-core.h" /* For internal_error. */ #include "gfortran.h" #include "trans.h" #include "trans-stmt.h" @@ -158,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_")); @@ -177,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 (); @@ -306,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", + void_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", + void_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", + void_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", + void_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", + void_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", + void_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", + void_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", + void_type_node, 1, dt_parm_type); + iocall[IOCALL_IOLENGTH_DONE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_iolength_done")), ".w", + void_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, + void_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); } @@ -446,10 +428,11 @@ set_parameter_const (stmtblock_t *block, tree var, enum iofield type, gfc_st_parameter_field *p = &st_parameter_field[type]; if (p->param_type == IOPARM_ptype_common) - var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field, - NULL_TREE); + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val)); return p->mask; } @@ -482,16 +465,18 @@ set_parameter_value (stmtblock_t *block, tree var, enum iofield type, /* UNIT numbers should be greater than the min. */ i = gfc_validate_kind (BT_INTEGER, 4, false); val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4); - cond = fold_build2 (LT_EXPR, boolean_type_node, se.expr, - fold_convert (TREE_TYPE (se.expr), val)); + cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + se.expr, + fold_convert (TREE_TYPE (se.expr), val)); gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT, "Unit number in I/O statement too small", &se.pre); /* UNIT numbers should be less than the max. */ val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); - cond = fold_build2 (GT_EXPR, boolean_type_node, se.expr, - fold_convert (TREE_TYPE (se.expr), val)); + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + se.expr, + fold_convert (TREE_TYPE (se.expr), val)); gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT, "Unit number in I/O statement too large", &se.pre); @@ -502,10 +487,12 @@ set_parameter_value (stmtblock_t *block, tree var, enum iofield type, gfc_add_block_to_block (block, &se.pre); if (p->param_type == IOPARM_ptype_common) - var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - tmp = fold_build3 (COMPONENT_REF, dest_type, var, p->field, NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var, + p->field, NULL_TREE); gfc_add_modify (block, tmp, se.expr); return p->mask; } @@ -560,10 +547,11 @@ set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock, } if (p->param_type == IOPARM_ptype_common) - var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), - var, p->field, NULL_TREE); + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); gfc_add_modify (block, tmp, addr); return p->mask; } @@ -601,21 +589,26 @@ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) { gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); size = gfc_conv_array_stride (array, rank); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - gfc_conv_array_ubound (array, rank), - gfc_conv_array_lbound (array, rank)); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, - gfc_index_one_node); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_conv_array_ubound (array, rank), + gfc_conv_array_lbound (array, rank)); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, size); } gcc_assert (size); - size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, - TREE_OPERAND (se->expr, 1)); + size = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, size, + TREE_OPERAND (se->expr, 1)); se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, - fold_convert (gfc_array_index_type, tmp)); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, + fold_convert (gfc_array_index_type, tmp)); se->string_length = fold_convert (gfc_charlen_type_node, size); return; } @@ -641,12 +634,14 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, gfc_init_se (&se, NULL); if (p->param_type == IOPARM_ptype_common) - var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - io = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), var, p->field, NULL_TREE); - len = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field_len), - var, p->field_len, NULL_TREE); + len = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (p->field_len), + var, p->field_len, NULL_TREE); /* Integer variable assigned a format label. */ if (e->ts.type == BT_INTEGER @@ -658,8 +653,8 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, gfc_conv_label_variable (&se, e); tmp = GFC_DECL_STRING_LEN (se.expr); - cond = fold_build2 (LT_EXPR, boolean_type_node, - tmp, build_int_cst (TREE_TYPE (tmp), 0)); + cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + tmp, build_int_cst (TREE_TYPE (tmp), 0)); asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format " "label", e->symtree->name); @@ -712,13 +707,13 @@ set_internal_unit (stmtblock_t * block, stmtblock_t * post_block, p = &st_parameter_field[IOPARM_dt_internal_unit]; mask = p->mask; - io = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), - var, p->field, NULL_TREE); - len = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field_len), - var, p->field_len, NULL_TREE); + io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + len = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field_len), + var, p->field_len, NULL_TREE); p = &st_parameter_field[IOPARM_dt_internal_unit_desc]; - desc = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), - var, p->field, NULL_TREE); + desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); gcc_assert (e->ts.type == BT_CHARACTER); @@ -827,13 +822,14 @@ io_result (stmtblock_t * block, tree var, gfc_st_label * err_label, tmp = gfc_finish_block (&body); - var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - rc = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), - var, p->field, NULL_TREE); - rc = fold_build2 (BIT_AND_EXPR, TREE_TYPE (rc), - rc, build_int_cst (TREE_TYPE (rc), - IOPARM_common_libreturn_mask)); + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + rc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + rc = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (rc), + rc, build_int_cst (TREE_TYPE (rc), + IOPARM_common_libreturn_mask)); tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE); @@ -852,11 +848,12 @@ set_error_locus (stmtblock_t * block, tree var, locus * where) int line; gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename]; - locus_file = fold_build3 (COMPONENT_REF, - st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - locus_file = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), - locus_file, p->field, NULL_TREE); + locus_file = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + locus_file = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (p->field), locus_file, + p->field, NULL_TREE); f = where->lb->file; str = gfc_build_cstring_const (f->filename); @@ -1391,21 +1388,6 @@ gfc_trans_wait (gfc_code * code) } -static gfc_expr * -gfc_new_nml_name_expr (const char * name) -{ - gfc_expr * nml_name; - - nml_name = gfc_get_expr(); - nml_name->ref = NULL; - nml_name->expr_type = EXPR_CONSTANT; - nml_name->ts.kind = gfc_default_character_kind; - nml_name->ts.type = BT_CHARACTER; - nml_name->value.character.length = strlen(name); - nml_name->value.character.string = gfc_char_to_widechar (name); - - return nml_name; -} /* nml_full_name builds up the fully qualified name of a derived type component. */ @@ -1481,8 +1463,8 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c, the derived type. */ if (TREE_CODE (decl) == FIELD_DECL) - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), - base_addr, tmp, NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), + base_addr, tmp, NULL_TREE); /* If we have a derived type component, a reference to the first element of the array is built. This is done so that base_addr, @@ -1687,7 +1669,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 @@ -1776,7 +1759,9 @@ build_dt (tree function, gfc_code * code) if (dt->format_expr || dt->format_label) gfc_internal_error ("build_dt: format with namelist"); - nmlname = gfc_new_nml_name_expr (dt->namelist->name); + nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL, + dt->namelist->name, + strlen (dt->namelist->name)); mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name, nmlname); @@ -1790,7 +1775,7 @@ build_dt (tree function, gfc_code * code) for (nml = dt->namelist->namelist; nml; nml = nml->next) transfer_namelist_element (&block, nml->sym->name, nml->sym, - NULL, NULL); + NULL, NULL_TREE); } else set_parameter_const (&block, var, IOPARM_common_flags, mask); @@ -1816,13 +1801,15 @@ build_dt (tree function, gfc_code * code) { gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags]; - tmp = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, - dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)), NULL_TREE); - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), - tmp, p->field, NULL_TREE); - tmp = fold_build2 (BIT_AND_EXPR, TREE_TYPE (tmp), - tmp, build_int_cst (TREE_TYPE (tmp), - IOPARM_common_libreturn_mask)); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)), + NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (p->field), tmp, p->field, NULL_TREE); + tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp), + tmp, build_int_cst (TREE_TYPE (tmp), + IOPARM_common_libreturn_mask)); } else /* IOLENGTH */ tmp = NULL_TREE; diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 016c5cff269..6fe362b778e 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -1,5 +1,6 @@ /* OpenMP directive translation -- generate GCC trees from gfc_code. - Copyright (C) 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. + Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 + Free Software Foundation, Inc. Contributed by Jakub Jelinek <jakub@redhat.com> This file is part of GCC. @@ -23,10 +24,8 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "gimple.h" -#include "ggc.h" -#include "toplev.h" -#include "real.h" +#include "gimple.h" /* For create_tmp_var_raw. */ +#include "diagnostic-core.h" /* For internal_error. */ #include "gfortran.h" #include "trans.h" #include "trans-stmt.h" @@ -57,7 +56,8 @@ gfc_omp_privatize_by_reference (const_tree decl) if (GFC_POINTER_TYPE_P (type)) return false; - if (!DECL_ARTIFICIAL (decl)) + if (!DECL_ARTIFICIAL (decl) + && TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE) return true; /* Some arrays are expanded as DECL_ARTIFICIAL pointers @@ -75,7 +75,10 @@ gfc_omp_privatize_by_reference (const_tree decl) enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree decl) { - if (DECL_ARTIFICIAL (decl) && ! GFC_DECL_RESULT (decl)) + if (DECL_ARTIFICIAL (decl) + && ! GFC_DECL_RESULT (decl) + && ! (DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl))) return OMP_CLAUSE_DEFAULT_SHARED; /* Cray pointees shouldn't be listed in any clauses and should be @@ -96,6 +99,15 @@ gfc_omp_predetermined_sharing (tree decl) == NULL) return OMP_CLAUSE_DEFAULT_SHARED; + /* Dummy procedures aren't considered variables by OpenMP, thus are + disallowed in OpenMP clauses. They are represented as PARM_DECLs + in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here + to avoid complaining about their uses with default(none). */ + if (TREE_CODE (decl) == PARM_DECL + && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE + && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE) + return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; + /* COMMON and EQUIVALENCE decls are shared. They are only referenced through DECL_VALUE_EXPR of the variables contained in them. If those are privatized, they will not be @@ -109,6 +121,19 @@ gfc_omp_predetermined_sharing (tree decl) return OMP_CLAUSE_DEFAULT_UNSPECIFIED; } +/* Return decl that should be used when reporting DEFAULT(NONE) + diagnostics. */ + +tree +gfc_omp_report_decl (tree decl) +{ + if (DECL_ARTIFICIAL (decl) + && DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + return GFC_DECL_SAVED_DESCRIPTOR (decl); + + return decl; +} /* Return true if DECL in private clause needs OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */ @@ -151,16 +176,17 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) gfc_add_modify (&cond_block, decl, outer); rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; size = gfc_conv_descriptor_ubound_get (decl, rank); - size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, - gfc_conv_descriptor_lbound_get (decl, rank)); - size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size, - gfc_index_one_node); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, gfc_conv_descriptor_lbound_get (decl, rank)); + size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); if (GFC_TYPE_ARRAY_RANK (type) > 1) - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, - gfc_conv_descriptor_stride_get (decl, rank)); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, gfc_conv_descriptor_stride_get (decl, rank)); esize = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, esize); size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block); ptr = gfc_allocate_array_with_status (&cond_block, build_int_cst (pvoid_type_node, 0), @@ -172,12 +198,12 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) gfc_conv_descriptor_data_set (&cond_block, decl, null_pointer_node); else_b = gfc_finish_block (&cond_block); - cond = fold_build2 (NE_EXPR, boolean_type_node, - fold_convert (pvoid_type_node, - gfc_conv_descriptor_data_get (outer)), - null_pointer_node); - gfc_add_expr_to_block (&block, build3 (COND_EXPR, void_type_node, - cond, then_b, else_b)); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + fold_convert (pvoid_type_node, + gfc_conv_descriptor_data_get (outer)), + null_pointer_node); + gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, + void_type_node, cond, then_b, else_b)); return gfc_finish_block (&block); } @@ -203,16 +229,17 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) gfc_add_modify (&block, dest, src); rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; size = gfc_conv_descriptor_ubound_get (dest, rank); - size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, - gfc_conv_descriptor_lbound_get (dest, rank)); - size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size, - gfc_index_one_node); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, gfc_conv_descriptor_lbound_get (dest, rank)); + size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); if (GFC_TYPE_ARRAY_RANK (type) > 1) - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, - gfc_conv_descriptor_stride_get (dest, rank)); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, gfc_conv_descriptor_stride_get (dest, rank)); esize = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, esize); size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); ptr = gfc_allocate_array_with_status (&block, build_int_cst (pvoid_type_node, 0), @@ -245,16 +272,17 @@ gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src) rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; size = gfc_conv_descriptor_ubound_get (dest, rank); - size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, - gfc_conv_descriptor_lbound_get (dest, rank)); - size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size, - gfc_index_one_node); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, gfc_conv_descriptor_lbound_get (dest, rank)); + size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); if (GFC_TYPE_ARRAY_RANK (type) > 1) - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, - gfc_conv_descriptor_stride_get (dest, rank)); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, gfc_conv_descriptor_stride_get (dest, rank)); esize = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, esize); size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); call = build_call_expr_loc (input_location, built_in_decls[BUILT_IN_MEMCPY], 3, @@ -609,16 +637,19 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) gfc_add_modify (&block, decl, outer_sym.backend_decl); rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; size = gfc_conv_descriptor_ubound_get (decl, rank); - size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, - gfc_conv_descriptor_lbound_get (decl, rank)); - size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size, - gfc_index_one_node); + size = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, size, + gfc_conv_descriptor_lbound_get (decl, rank)); + size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); if (GFC_TYPE_ARRAY_RANK (type) > 1) - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, - gfc_conv_descriptor_stride_get (decl, rank)); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, + gfc_conv_descriptor_stride_get (decl, rank)); esize = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, esize); size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); ptr = gfc_allocate_array_with_status (&block, build_int_cst (pvoid_type_node, 0), @@ -1075,7 +1106,8 @@ gfc_trans_omp_atomic (gfc_code *code) gfc_init_block (&rse.pre); gfc_conv_expr (&rse, arg->expr); gfc_add_block_to_block (&block, &rse.pre); - x = fold_build2 (op, TREE_TYPE (accum), accum, rse.expr); + x = fold_build2_loc (input_location, op, TREE_TYPE (accum), + accum, rse.expr); gfc_add_modify (&block, accum, x); } @@ -1091,13 +1123,14 @@ gfc_trans_omp_atomic (gfc_code *code) lhsaddr)); if (var_on_left) - x = fold_build2 (op, TREE_TYPE (rhs), x, rhs); + x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs); else - x = fold_build2 (op, TREE_TYPE (rhs), rhs, x); + x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x); if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE && TREE_CODE (type) != COMPLEX_TYPE) - x = fold_build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (rhs)), x); + x = fold_build1_loc (input_location, REALPART_EXPR, + TREE_TYPE (TREE_TYPE (rhs)), x); x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x)); gfc_add_expr_to_block (&block, x); @@ -1122,9 +1155,17 @@ gfc_trans_omp_critical (gfc_code *code) if (code->ext.omp_name != NULL) name = get_identifier (code->ext.omp_name); stmt = gfc_trans_code (code->block->next); - return build2 (OMP_CRITICAL, void_type_node, stmt, name); + return build2_loc (input_location, OMP_CRITICAL, void_type_node, stmt, name); } +typedef struct dovar_init_d { + tree var; + tree init; +} dovar_init; + +DEF_VEC_O(dovar_init); +DEF_VEC_ALLOC_O(dovar_init,heap); + static tree gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, gfc_omp_clauses *do_clauses, tree par_clauses) @@ -1136,7 +1177,9 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, stmtblock_t body; gfc_omp_clauses *clauses = code->ext.omp_clauses; int i, collapse = clauses->collapse; - tree dovar_init = NULL_TREE; + VEC(dovar_init,heap) *inits = NULL; + dovar_init *di; + unsigned ix; if (collapse <= 0) collapse = 1; @@ -1219,11 +1262,16 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, if (simple) { TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from); - TREE_VEC_ELT (cond, i) = fold_build2 (simple > 0 ? LE_EXPR : GE_EXPR, - boolean_type_node, dovar, to); - TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, dovar, step); - TREE_VEC_ELT (incr, i) = fold_build2 (MODIFY_EXPR, type, dovar, - TREE_VEC_ELT (incr, i)); + TREE_VEC_ELT (cond, i) = fold_build2_loc (input_location, simple > 0 + ? LE_EXPR : GE_EXPR, + boolean_type_node, dovar, + to); + TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR, + type, dovar, step); + TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, + MODIFY_EXPR, + type, dovar, + TREE_VEC_ELT (incr, i)); } else { @@ -1234,24 +1282,30 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, body; cycle_label:; } */ - tmp = fold_build2 (MINUS_EXPR, type, step, from); - tmp = fold_build2 (PLUS_EXPR, type, to, tmp); - tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step); + tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp); + tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp, + step); tmp = gfc_evaluate_now (tmp, pblock); count = gfc_create_var (type, "count"); TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count, build_int_cst (type, 0)); - TREE_VEC_ELT (cond, i) = fold_build2 (LT_EXPR, boolean_type_node, - count, tmp); - TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, count, - build_int_cst (type, 1)); - TREE_VEC_ELT (incr, i) = fold_build2 (MODIFY_EXPR, type, - count, TREE_VEC_ELT (incr, i)); + TREE_VEC_ELT (cond, i) = fold_build2_loc (input_location, LT_EXPR, + boolean_type_node, + count, tmp); + TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR, + type, count, + build_int_cst (type, 1)); + TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, + MODIFY_EXPR, type, count, + TREE_VEC_ELT (incr, i)); /* Initialize DOVAR. */ - tmp = fold_build2 (MULT_EXPR, type, count, step); - tmp = fold_build2 (PLUS_EXPR, type, from, tmp); - dovar_init = tree_cons (dovar, tmp, dovar_init); + tmp = fold_build2_loc (input_location, MULT_EXPR, type, count, step); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp); + di = VEC_safe_push (dovar_init, heap, inits, NULL); + di->var = dovar; + di->init = tmp; } if (!dovar_found) @@ -1273,8 +1327,10 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, will have the value on entry of the last loop, rather than value after iterator increment. */ tmp = gfc_evaluate_now (step, pblock); - tmp = fold_build2 (PLUS_EXPR, type, dovar, tmp); - tmp = fold_build2 (MODIFY_EXPR, type, dovar, tmp); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, dovar, + tmp); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, + dovar, tmp); for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c)) if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE && OMP_CLAUSE_DECL (c) == dovar_decl) @@ -1320,24 +1376,18 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, gfc_start_block (&body); - dovar_init = nreverse (dovar_init); - while (dovar_init) - { - gfc_add_modify (&body, TREE_PURPOSE (dovar_init), - TREE_VALUE (dovar_init)); - dovar_init = TREE_CHAIN (dovar_init); - } + FOR_EACH_VEC_ELT (dovar_init, inits, ix, di) + gfc_add_modify (&body, di->var, di->init); + VEC_free (dovar_init, heap, inits); /* Cycle statement is implemented with a goto. Exit statement must not be present for this loop. */ cycle_label = gfc_build_label_decl (NULL_TREE); - /* Put these labels where they can be found later. We put the - labels in a TREE_LIST node (because TREE_CHAIN is already - used). cycle_label goes in TREE_PURPOSE (backend_decl), exit - label in TREE_VALUE (backend_decl). */ + /* Put these labels where they can be found later. */ - code->block->backend_decl = tree_cons (cycle_label, NULL, NULL); + code->cycle_label = cycle_label; + code->exit_label = NULL_TREE; /* Main loop body. */ tmp = gfc_trans_omp_code (code->block->next, true); @@ -1396,7 +1446,8 @@ gfc_trans_omp_parallel (gfc_code *code) omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, code->loc); stmt = gfc_trans_omp_code (code->block->next, true); - stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses); + stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, + omp_clauses); gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); } @@ -1436,7 +1487,8 @@ gfc_trans_omp_parallel_do (gfc_code *code) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else poplevel (0, 0, 0); - stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses); + stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, + omp_clauses); OMP_PARALLEL_COMBINED (stmt) = 1; gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); @@ -1461,7 +1513,8 @@ gfc_trans_omp_parallel_sections (gfc_code *code) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else poplevel (0, 0, 0); - stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses); + stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, + omp_clauses); OMP_PARALLEL_COMBINED (stmt) = 1; gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); @@ -1486,7 +1539,8 @@ gfc_trans_omp_parallel_workshare (gfc_code *code) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0)); else poplevel (0, 0, 0); - stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses); + stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, + omp_clauses); OMP_PARALLEL_COMBINED (stmt) = 1; gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); @@ -1518,7 +1572,8 @@ gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses) } stmt = gfc_finish_block (&body); - stmt = build2 (OMP_SECTIONS, void_type_node, stmt, omp_clauses); + stmt = build2_loc (input_location, OMP_SECTIONS, void_type_node, stmt, + omp_clauses); gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); @@ -1529,7 +1584,8 @@ gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses) { tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc); tree stmt = gfc_trans_omp_code (code->block->next, true); - stmt = build2 (OMP_SINGLE, void_type_node, stmt, omp_clauses); + stmt = build2_loc (input_location, OMP_SINGLE, void_type_node, stmt, + omp_clauses); return stmt; } @@ -1543,7 +1599,8 @@ gfc_trans_omp_task (gfc_code *code) omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, code->loc); stmt = gfc_trans_omp_code (code->block->next, true); - stmt = build2 (OMP_TASK, void_type_node, stmt, omp_clauses); + stmt = build2_loc (input_location, OMP_TASK, void_type_node, stmt, + omp_clauses); gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); } @@ -1658,7 +1715,8 @@ gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses) { /* Finish single block and add it to pblock. */ tmp = gfc_finish_block (&singleblock); - tmp = build2 (OMP_SINGLE, void_type_node, tmp, NULL_TREE); + tmp = build2_loc (input_location, OMP_SINGLE, + void_type_node, tmp, NULL_TREE); gfc_add_expr_to_block (pblock, tmp); /* Add current gfc_code to pblock. */ gfc_add_expr_to_block (pblock, res); @@ -1687,10 +1745,10 @@ gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses) { /* Finish single block and add it to pblock. */ tmp = gfc_finish_block (&singleblock); - tmp = build2 (OMP_SINGLE, void_type_node, tmp, - clauses->nowait - ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT) - : NULL_TREE); + tmp = build2_loc (input_location, OMP_SINGLE, void_type_node, tmp, + clauses->nowait + ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT) + : NULL_TREE); gfc_add_expr_to_block (pblock, tmp); } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 0b215f2395d..82cddd7c226 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -25,10 +25,6 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "gimple.h" -#include "ggc.h" -#include "toplev.h" -#include "real.h" #include "gfortran.h" #include "flags.h" #include "trans.h" @@ -38,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 { @@ -152,8 +149,8 @@ gfc_trans_goto (gfc_code * code) gfc_start_block (&se.pre); gfc_conv_label_variable (&se, code->expr1); tmp = GFC_DECL_STRING_LEN (se.expr); - tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, - build_int_cst (TREE_TYPE (tmp), -1)); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, + build_int_cst (TREE_TYPE (tmp), -1)); gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc, "Assigned label is not a target label"); @@ -165,7 +162,8 @@ gfc_trans_goto (gfc_code * code) that's a very fragile business and may break with optimization. So just ignore it. */ - target = fold_build1 (GOTO_EXPR, void_type_node, assigned_goto); + target = fold_build1_loc (input_location, GOTO_EXPR, void_type_node, + assigned_goto); gfc_add_expr_to_block (&se.pre, target); return gfc_finish_block (&se.pre); } @@ -242,6 +240,7 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, /* Make a local loopinfo for the temporary creation, so that none of the other ss->info's have to be renormalized. */ gfc_init_loopinfo (&tmp_loop); + tmp_loop.dimen = info->dimen; for (n = 0; n < info->dimen; n++) { tmp_loop.to[n] = loopse->loop->to[n]; @@ -324,10 +323,11 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, { tmp = gfc_conv_descriptor_stride_get (info->descriptor, gfc_rank_cst[n]); - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - loopse->loop->from[n], tmp); - offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, - offset, tmp); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + loopse->loop->from[n], tmp); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, offset, tmp); } info->offset = gfc_create_var (gfc_array_index_type, NULL); gfc_add_modify (&se->pre, info->offset, offset); @@ -377,7 +377,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; @@ -455,22 +455,22 @@ gfc_trans_call (gfc_code * code, bool dependency_check, index = count1; maskexpr = gfc_build_array_ref (mask, index, NULL); if (invert) - maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), - maskexpr); + maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, + TREE_TYPE (maskexpr), maskexpr); } /* 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) { tmp = build3_v (COND_EXPR, maskexpr, loopse.expr, build_empty_stmt (input_location)); gfc_add_expr_to_block (&loopse.pre, tmp); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - count1, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + count1, gfc_index_one_node); gfc_add_modify (&loopse.pre, count1, tmp); } else @@ -495,7 +495,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) { @@ -504,16 +504,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); @@ -521,17 +521,21 @@ gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED) gfc_conv_expr (&se, code->expr1); - tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (result), result, - fold_convert (TREE_TYPE (result), se.expr)); + /* 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_loc (input_location, 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 (); } @@ -552,9 +556,17 @@ gfc_trans_pause (gfc_code * code) if (code->expr1 == NULL) { - tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code); + tmp = build_int_cst (gfc_int4_type_node, 0); tmp = build_call_expr_loc (input_location, - gfor_fndecl_pause_numeric, 1, tmp); + gfor_fndecl_pause_string, 2, + build_int_cst (pchar_type_node, 0), tmp); + } + else if (code->expr1->ts.type == BT_INTEGER) + { + gfc_conv_expr (&se, code->expr1); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_pause_numeric, 1, + fold_convert (gfc_int4_type_node, se.expr)); } else { @@ -588,17 +600,27 @@ gfc_trans_stop (gfc_code *code, bool error_stop) if (code->expr1 == NULL) { - tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code); + tmp = build_int_cst (gfc_int4_type_node, 0); + tmp = build_call_expr_loc (input_location, + error_stop ? gfor_fndecl_error_stop_string + : gfor_fndecl_stop_string, + 2, build_int_cst (pchar_type_node, 0), tmp); + } + else if (code->expr1->ts.type == BT_INTEGER) + { + gfc_conv_expr (&se, code->expr1); tmp = build_call_expr_loc (input_location, - gfor_fndecl_stop_numeric, 1, tmp); + error_stop ? gfor_fndecl_error_stop_numeric + : gfor_fndecl_stop_numeric, 1, + fold_convert (gfc_int4_type_node, se.expr)); } else { gfc_conv_expr_reference (&se, code->expr1); tmp = build_call_expr_loc (input_location, - error_stop ? gfor_fndecl_error_stop_string - : gfor_fndecl_stop_string, - 2, se.expr, se.string_length); + error_stop ? gfor_fndecl_error_stop_string + : gfor_fndecl_stop_string, + 2, se.expr, se.string_length); } gfc_add_expr_to_block (&se.pre, tmp); @@ -627,8 +649,8 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type __attribute__ ((unused))) { tree cond; gfc_conv_expr (&se, code->expr1); - cond = fold_build2 (NE_EXPR, boolean_type_node, se.expr, - build_int_cst (TREE_TYPE (se.expr), 1)); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + se.expr, build_int_cst (TREE_TYPE (se.expr), 1)); gfc_trans_runtime_check (true, false, cond, &se.pre, &code->expr1->where, "Invalid image number " "%d in SYNC IMAGES", @@ -717,7 +739,8 @@ gfc_trans_if_1 (gfc_code * code) elsestmt = build_empty_stmt (input_location); /* Build the condition expression and add it to the condition block. */ - stmt = fold_build3 (COND_EXPR, void_type_node, if_se.expr, stmt, elsestmt); + stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node, + if_se.expr, stmt, elsestmt); gfc_add_expr_to_block (&if_se.pre, stmt); @@ -728,10 +751,21 @@ gfc_trans_if_1 (gfc_code * code) tree gfc_trans_if (gfc_code * code) { - /* Ignore the top EXEC_IF, it only announces an IF construct. The - actual code we must translate is in code->block. */ + stmtblock_t body; + tree exit_label; - return gfc_trans_if_1 (code->block); + /* Create exit label so it is available for trans'ing the body code. */ + exit_label = gfc_build_label_decl (NULL_TREE); + code->exit_label = exit_label; + + /* Translate the actual code in code->block. */ + gfc_init_block (&body); + gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block)); + + /* Add exit label. */ + gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label)); + + return gfc_finish_block (&body); } @@ -786,11 +820,14 @@ gfc_trans_arithmetic_if (gfc_code * code) branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2)); if (code->label1->value != code->label3->value) - tmp = fold_build2 (LT_EXPR, boolean_type_node, se.expr, zero); + tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + se.expr, zero); else - tmp = fold_build2 (NE_EXPR, boolean_type_node, se.expr, zero); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + se.expr, zero); - branch1 = fold_build3 (COND_EXPR, void_type_node, tmp, branch1, branch2); + branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node, + tmp, branch1, branch2); } else branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1)); @@ -800,8 +837,10 @@ gfc_trans_arithmetic_if (gfc_code * code) { /* if (cond <= 0) take branch1 else take branch2. */ branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3)); - tmp = fold_build2 (LE_EXPR, boolean_type_node, se.expr, zero); - branch1 = fold_build3 (COND_EXPR, void_type_node, tmp, branch1, branch2); + tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, + se.expr, zero); + branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node, + tmp, branch1, branch2); } /* Append the COND_EXPR to the evaluation of COND, and return. */ @@ -833,25 +872,32 @@ gfc_trans_block_construct (gfc_code* code) { gfc_namespace* ns; gfc_symbol* sym; + gfc_wrapped_block block; + tree exit_label; stmtblock_t body; - tree tmp; - ns = code->ext.ns; + ns = code->ext.block.ns; gcc_assert (ns); sym = ns->proc_name; gcc_assert (sym); + /* Process local variables. */ gcc_assert (!sym->tlink); sym->tlink = sym; + gfc_process_block_locals (ns, code->ext.block.assoc); - gfc_start_block (&body); - gfc_process_block_locals (ns); + /* Generate code including exit-label. */ + gfc_init_block (&body); + exit_label = gfc_build_label_decl (NULL_TREE); + code->exit_label = exit_label; + gfc_add_expr_to_block (&body, gfc_trans_code (ns->code)); + gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label)); - tmp = gfc_trans_code (ns->code); - tmp = gfc_trans_deferred_vars (sym, tmp); + /* Finish everything. */ + gfc_start_wrapped_block (&block, gfc_finish_block (&body)); + gfc_trans_deferred_vars (sym, &block); - gfc_add_expr_to_block (&body, tmp); - return gfc_finish_block (&body); + return gfc_finish_wrapped_block (&block); } @@ -914,7 +960,8 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, exit_label = gfc_build_label_decl (NULL_TREE); /* Put the labels where they can be found later. See gfc_trans_do(). */ - code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL); + code->cycle_label = cycle_label; + code->exit_label = exit_label; /* Loop body. */ gfc_start_block (&body); @@ -933,7 +980,8 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, /* Check whether someone has modified the loop variable. */ if (gfc_option.rtcheck & GFC_RTCHECK_DO) { - tmp = fold_build2 (NE_EXPR, boolean_type_node, dovar, saved_dovar); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + dovar, saved_dovar); gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, "Loop variable has been modified"); } @@ -942,17 +990,19 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, if (exit_cond) { tmp = build1_v (GOTO_EXPR, exit_label); - tmp = fold_build3 (COND_EXPR, void_type_node, exit_cond, tmp, - build_empty_stmt (input_location)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + exit_cond, tmp, + build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); } /* Evaluate the loop condition. */ - cond = fold_build2 (EQ_EXPR, boolean_type_node, dovar, to); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, dovar, + to); cond = gfc_evaluate_now (cond, &body); /* Increment the loop variable. */ - tmp = fold_build2 (PLUS_EXPR, type, dovar, step); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, dovar, step); gfc_add_modify (&body, dovar, tmp); if (gfc_option.rtcheck & GFC_RTCHECK_DO) @@ -961,8 +1011,8 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, /* The loop exit. */ tmp = build1_v (GOTO_EXPR, exit_label); TREE_USED (exit_label) = 1; - tmp = fold_build3 (COND_EXPR, void_type_node, - cond, tmp, build_empty_stmt (input_location)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); /* Finish the loop body. */ @@ -971,11 +1021,13 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, /* Only execute the loop if the number of iterations is positive. */ if (tree_int_cst_sgn (step) > 0) - cond = fold_build2 (LE_EXPR, boolean_type_node, dovar, to); + cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, dovar, + to); else - cond = fold_build2 (GE_EXPR, boolean_type_node, dovar, to); - tmp = fold_build3 (COND_EXPR, void_type_node, - cond, tmp, build_empty_stmt (input_location)); + cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, dovar, + to); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, + build_empty_stmt (input_location)); gfc_add_expr_to_block (pblock, tmp); /* Add the exit label. */ @@ -1065,8 +1117,8 @@ gfc_trans_do (gfc_code * code, tree exit_cond) if (gfc_option.rtcheck & GFC_RTCHECK_DO) { - tmp = fold_build2 (EQ_EXPR, boolean_type_node, step, - fold_convert (type, integer_zero_node)); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, step, + fold_convert (type, integer_zero_node)); gfc_trans_runtime_check (true, false, tmp, &block, &code->loc, "DO step value is zero"); } @@ -1077,8 +1129,8 @@ gfc_trans_do (gfc_code * code, tree exit_cond) || tree_int_cst_equal (step, integer_minus_one_node))) return gfc_trans_simple_do (code, &block, dovar, from, to, step, exit_cond); - pos_step = fold_build2 (GT_EXPR, boolean_type_node, step, - fold_convert (type, integer_zero_node)); + pos_step = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, step, + fold_convert (type, integer_zero_node)); if (TREE_CODE (type) == INTEGER_TYPE) utype = unsigned_type_for (type); @@ -1091,6 +1143,10 @@ gfc_trans_do (gfc_code * code, tree exit_cond) exit_label = gfc_build_label_decl (NULL_TREE); TREE_USED (exit_label) = 1; + /* Put these labels where they can be found later. */ + code->cycle_label = cycle_label; + code->exit_label = exit_label; + /* Initialize the DO variable: dovar = from. */ gfc_add_modify (&block, dovar, from); @@ -1124,36 +1180,43 @@ gfc_trans_do (gfc_code * code, tree exit_cond) /* Calculate SIGN (1,step), as (step < 0 ? -1 : 1) */ - tmp = fold_build2 (LT_EXPR, boolean_type_node, step, - build_int_cst (TREE_TYPE (step), 0)); - step_sign = fold_build3 (COND_EXPR, type, tmp, - build_int_cst (type, -1), - build_int_cst (type, 1)); + tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, step, + build_int_cst (TREE_TYPE (step), 0)); + step_sign = fold_build3_loc (input_location, COND_EXPR, type, tmp, + build_int_cst (type, -1), + build_int_cst (type, 1)); - tmp = fold_build2 (LT_EXPR, boolean_type_node, to, from); - pos = fold_build3 (COND_EXPR, void_type_node, tmp, - build1_v (GOTO_EXPR, exit_label), - build_empty_stmt (input_location)); + tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, to, + from); + pos = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, + build1_v (GOTO_EXPR, exit_label), + build_empty_stmt (input_location)); - tmp = fold_build2 (GT_EXPR, boolean_type_node, to, from); - neg = fold_build3 (COND_EXPR, void_type_node, tmp, - build1_v (GOTO_EXPR, exit_label), - build_empty_stmt (input_location)); - tmp = fold_build3 (COND_EXPR, void_type_node, pos_step, pos, neg); + tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, to, + from); + neg = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, + build1_v (GOTO_EXPR, exit_label), + build_empty_stmt (input_location)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + pos_step, pos, neg); gfc_add_expr_to_block (&block, tmp); /* Calculate the loop count. to-from can overflow, so we cast to unsigned. */ - to2 = fold_build2 (MULT_EXPR, type, step_sign, to); - from2 = fold_build2 (MULT_EXPR, type, step_sign, from); - step2 = fold_build2 (MULT_EXPR, type, step_sign, step); + to2 = fold_build2_loc (input_location, MULT_EXPR, type, step_sign, to); + from2 = fold_build2_loc (input_location, MULT_EXPR, type, step_sign, + from); + step2 = fold_build2_loc (input_location, MULT_EXPR, type, step_sign, + step); step2 = fold_convert (utype, step2); - tmp = fold_build2 (MINUS_EXPR, type, to2, from2); + tmp = fold_build2_loc (input_location, MINUS_EXPR, type, to2, from2); tmp = fold_convert (utype, tmp); - tmp = fold_build2 (TRUNC_DIV_EXPR, utype, tmp, step2); - tmp = fold_build2 (MODIFY_EXPR, void_type_node, countm1, tmp); + tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, utype, tmp, + step2); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + countm1, tmp); gfc_add_expr_to_block (&block, tmp); } else @@ -1162,18 +1225,21 @@ gfc_trans_do (gfc_code * code, tree exit_cond) This would probably cause more problems that it solves when we implement "long double" types. */ - tmp = fold_build2 (MINUS_EXPR, type, to, from); - tmp = fold_build2 (RDIV_EXPR, type, tmp, step); - tmp = fold_build1 (FIX_TRUNC_EXPR, utype, tmp); + tmp = fold_build2_loc (input_location, MINUS_EXPR, type, to, from); + tmp = fold_build2_loc (input_location, RDIV_EXPR, type, tmp, step); + tmp = fold_build1_loc (input_location, FIX_TRUNC_EXPR, utype, tmp); gfc_add_modify (&block, countm1, tmp); /* We need a special check for empty loops: empty = (step > 0 ? to < from : to > from); */ - tmp = fold_build3 (COND_EXPR, boolean_type_node, pos_step, - fold_build2 (LT_EXPR, boolean_type_node, to, from), - fold_build2 (GT_EXPR, boolean_type_node, to, from)); + tmp = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, + pos_step, + fold_build2_loc (input_location, LT_EXPR, + boolean_type_node, to, from), + fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, to, from)); /* If the loop is empty, go directly to the exit label. */ - tmp = fold_build3 (COND_EXPR, void_type_node, tmp, + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, build1_v (GOTO_EXPR, exit_label), build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); @@ -1182,13 +1248,6 @@ gfc_trans_do (gfc_code * code, tree exit_cond) /* Loop body. */ gfc_start_block (&body); - /* Put these labels where they can be found later. We put the - labels in a TREE_LIST node (because TREE_CHAIN is already - used). cycle_label goes in TREE_PURPOSE (backend_decl), exit - label in TREE_VALUE (backend_decl). */ - - code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL); - /* Main loop body. */ tmp = gfc_trans_code_cond (code->block->next, exit_cond); gfc_add_expr_to_block (&body, tmp); @@ -1203,7 +1262,8 @@ gfc_trans_do (gfc_code * code, tree exit_cond) /* Check whether someone has modified the loop variable. */ if (gfc_option.rtcheck & GFC_RTCHECK_DO) { - tmp = fold_build2 (NE_EXPR, boolean_type_node, dovar, saved_dovar); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, dovar, + saved_dovar); gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, "Loop variable has been modified"); } @@ -1212,28 +1272,30 @@ gfc_trans_do (gfc_code * code, tree exit_cond) if (exit_cond) { tmp = build1_v (GOTO_EXPR, exit_label); - tmp = fold_build3 (COND_EXPR, void_type_node, exit_cond, tmp, - build_empty_stmt (input_location)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + exit_cond, tmp, + build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); } /* Increment the loop variable. */ - tmp = fold_build2 (PLUS_EXPR, type, dovar, step); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, dovar, step); gfc_add_modify (&body, dovar, tmp); if (gfc_option.rtcheck & GFC_RTCHECK_DO) gfc_add_modify (&body, saved_dovar, dovar); /* End with the loop condition. Loop until countm1 == 0. */ - cond = fold_build2 (EQ_EXPR, boolean_type_node, countm1, - build_int_cst (utype, 0)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, countm1, + build_int_cst (utype, 0)); tmp = build1_v (GOTO_EXPR, exit_label); - tmp = fold_build3 (COND_EXPR, void_type_node, - cond, tmp, build_empty_stmt (input_location)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); /* Decrement the loop count. */ - tmp = fold_build2 (MINUS_EXPR, utype, countm1, build_int_cst (utype, 1)); + tmp = fold_build2_loc (input_location, MINUS_EXPR, utype, countm1, + build_int_cst (utype, 1)); gfc_add_modify (&body, countm1, tmp); /* End of loop body. */ @@ -1291,19 +1353,21 @@ gfc_trans_do_while (gfc_code * code) exit_label = gfc_build_label_decl (NULL_TREE); /* Put the labels where they can be found later. See gfc_trans_do(). */ - code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL); + code->cycle_label = cycle_label; + code->exit_label = exit_label; /* Create a GIMPLE version of the exit condition. */ gfc_init_se (&cond, NULL); gfc_conv_expr_val (&cond, code->expr1); gfc_add_block_to_block (&block, &cond.pre); - cond.expr = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr); + cond.expr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, + boolean_type_node, cond.expr); /* Build "IF (! cond) GOTO exit_label". */ tmp = build1_v (GOTO_EXPR, exit_label); TREE_USED (exit_label) = 1; - tmp = fold_build3 (COND_EXPR, void_type_node, - cond.expr, tmp, build_empty_stmt (input_location)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond.expr, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); /* The main body of the loop. */ @@ -1456,8 +1520,8 @@ gfc_trans_integer_select (gfc_code * code) /* Add this case label. Add parameter 'label', make it match GCC backend. */ - tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, - low, high, label); + tmp = fold_build3_loc (input_location, CASE_LABEL_EXPR, + void_type_node, low, high, label); gfc_add_expr_to_block (&body, tmp); } @@ -1572,8 +1636,8 @@ gfc_trans_logical_select (gfc_code * code) if (f != NULL) false_tree = gfc_trans_code (f->next); - stmt = fold_build3 (COND_EXPR, void_type_node, se.expr, - true_tree, false_tree); + stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node, + se.expr, true_tree, false_tree); gfc_add_expr_to_block (&block, stmt); } @@ -1581,6 +1645,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 @@ -1593,21 +1661,175 @@ gfc_trans_logical_select (gfc_code * code) static tree gfc_trans_character_select (gfc_code *code) { - tree init, node, end_label, tmp, type, case_num, label, fndecl; + tree init, end_label, tmp, type, case_num, label, fndecl; 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 (integer_onep (expr1se.string_length)) + { + 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_loc (input_location, 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; @@ -1618,6 +1840,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) @@ -1628,10 +1851,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); @@ -1645,28 +1869,20 @@ 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); + tmp = fold_build3_loc (input_location, CASE_LABEL_EXPR, + void_type_node, + (d->low == NULL && d->high == NULL) + ? NULL : build_int_cst (NULL_TREE, d->n), + NULL, label); gfc_add_expr_to_block (&body, tmp); } @@ -1678,52 +1894,50 @@ gfc_trans_character_select (gfc_code *code) } /* Generate the structure describing the branches */ - init = NULL_TREE; - - for(d = cp; d; d = d->right) + for (d = cp; d; d = d->right) { - node = NULL_TREE; + VEC(constructor_elt,gc) *node = NULL; gfc_init_se (&se, NULL); if (d->low == NULL) { - node = tree_cons (ss_string1[k], null_pointer_node, node); - node = tree_cons (ss_string1_len[k], integer_zero_node, node); + CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node); + CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], integer_zero_node); } else { gfc_conv_expr_reference (&se, d->low); - node = tree_cons (ss_string1[k], se.expr, node); - node = tree_cons (ss_string1_len[k], se.string_length, node); + CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr); + CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length); } if (d->high == NULL) { - node = tree_cons (ss_string2[k], null_pointer_node, node); - node = tree_cons (ss_string2_len[k], integer_zero_node, node); + CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node); + CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], integer_zero_node); } else { gfc_init_se (&se, NULL); gfc_conv_expr_reference (&se, d->high); - node = tree_cons (ss_string2[k], se.expr, node); - node = tree_cons (ss_string2_len[k], se.string_length, node); + CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr); + CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length); } - node = tree_cons (ss_target[k], build_int_cst (integer_type_node, d->n), - node); + CONSTRUCTOR_APPEND_ELT (node, ss_target[k], + build_int_cst (integer_type_node, d->n)); - tmp = build_constructor_from_list (select_struct[k], nreverse (node)); - init = tree_cons (NULL_TREE, tmp, init); + tmp = build_constructor (select_struct[k], node); + CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp); } type = build_array_type (select_struct[k], build_index_type (build_int_cst (NULL_TREE, n-1))); - init = build_constructor_from_list (type, nreverse(init)); + init = build_constructor (type, inits); TREE_CONSTANT (init) = 1; TREE_STATIC (init) = 1; /* Create a static variable to hold the jump table. */ @@ -1737,11 +1951,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) @@ -1751,11 +1960,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); @@ -1785,22 +1994,47 @@ gfc_trans_character_select (gfc_code *code) tree gfc_trans_select (gfc_code * code) { + stmtblock_t block; + tree body; + tree exit_label; + gcc_assert (code && code->expr1); + gfc_init_block (&block); + + /* Build the exit label and hang it in. */ + exit_label = gfc_build_label_decl (NULL_TREE); + code->exit_label = exit_label; /* Empty SELECT constructs are legal. */ if (code->block == NULL) - return build_empty_stmt (input_location); + body = build_empty_stmt (input_location); /* Select the correct translation function. */ - switch (code->expr1->ts.type) - { - case BT_LOGICAL: return gfc_trans_logical_select (code); - case BT_INTEGER: return gfc_trans_integer_select (code); - case BT_CHARACTER: return gfc_trans_character_select (code); - default: - gfc_internal_error ("gfc_trans_select(): Bad type for case expr."); - /* Not reached */ - } + else + switch (code->expr1->ts.type) + { + case BT_LOGICAL: + body = gfc_trans_logical_select (code); + break; + + case BT_INTEGER: + body = gfc_trans_integer_select (code); + break; + + case BT_CHARACTER: + body = gfc_trans_character_select (code); + break; + + default: + gfc_internal_error ("gfc_trans_select(): Bad type for case expr."); + /* Not reached */ + } + + /* Build everything together. */ + gfc_add_expr_to_block (&block, body); + gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)); + + return gfc_finish_block (&block); } @@ -2060,18 +2294,19 @@ gfc_trans_forall_loop (forall_info *forall_tmp, tree body, gfc_init_block (&block); /* The exit condition. */ - cond = fold_build2 (LE_EXPR, boolean_type_node, - count, build_int_cst (TREE_TYPE (count), 0)); + cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, + count, build_int_cst (TREE_TYPE (count), 0)); tmp = build1_v (GOTO_EXPR, exit_label); - tmp = fold_build3 (COND_EXPR, void_type_node, - cond, tmp, build_empty_stmt (input_location)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); /* The main loop body. */ gfc_add_expr_to_block (&block, body); /* Increment the loop variable. */ - tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (var), var, step); + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, + step); gfc_add_modify (&block, var, tmp); /* Advance to the next mask element. Only do this for the @@ -2079,14 +2314,14 @@ gfc_trans_forall_loop (forall_info *forall_tmp, tree body, if (n == 0 && mask_flag && forall_tmp->mask) { tree maskindex = forall_tmp->maskindex; - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - maskindex, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + maskindex, gfc_index_one_node); gfc_add_modify (&block, maskindex, tmp); } /* Decrement the loop counter. */ - tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (var), count, - build_int_cst (TREE_TYPE (var), 1)); + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count, + build_int_cst (TREE_TYPE (var), 1)); gfc_add_modify (&block, count, tmp); body = gfc_finish_block (&block); @@ -2097,9 +2332,12 @@ gfc_trans_forall_loop (forall_info *forall_tmp, tree body, /* Initialize the loop counter. */ - tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (var), step, start); - tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (var), end, tmp); - tmp = fold_build2 (TRUNC_DIV_EXPR, TREE_TYPE (var), tmp, step); + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step, + start); + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end, + tmp); + tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var), + tmp, step); gfc_add_modify (&block, count, tmp); /* The loop expression. */ @@ -2172,10 +2410,8 @@ gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock, tree tmp; if (INTEGER_CST_P (size)) - { - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, - gfc_index_one_node); - } + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); else tmp = NULL_TREE; @@ -2233,8 +2469,8 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3, gfc_add_block_to_block (&block, &lse.post); /* Increment the count1. */ - tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1, - gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1), + count1, gfc_index_one_node); gfc_add_modify (&block, count1, tmp); tmp = gfc_finish_block (&block); @@ -2279,26 +2515,27 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3, { wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL); if (invert) - wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR, - TREE_TYPE (wheremaskexpr), - wheremaskexpr); - tmp = fold_build3 (COND_EXPR, void_type_node, - wheremaskexpr, tmp, - build_empty_stmt (input_location)); + wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, + TREE_TYPE (wheremaskexpr), + wheremaskexpr); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + wheremaskexpr, tmp, + build_empty_stmt (input_location)); } gfc_add_expr_to_block (&body, tmp); /* Increment count1. */ - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - count1, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + count1, gfc_index_one_node); gfc_add_modify (&body, count1, tmp); /* Increment count3. */ if (count3) { - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - count3, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, count3, + gfc_index_one_node); gfc_add_modify (&body, count3, tmp); } @@ -2377,11 +2614,12 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3, { wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL); if (invert) - wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR, - TREE_TYPE (wheremaskexpr), - wheremaskexpr); - tmp = fold_build3 (COND_EXPR, void_type_node, - wheremaskexpr, tmp, build_empty_stmt (input_location)); + wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, + TREE_TYPE (wheremaskexpr), + wheremaskexpr); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + wheremaskexpr, tmp, + build_empty_stmt (input_location)); } gfc_add_expr_to_block (&body1, tmp); @@ -2391,22 +2629,23 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3, gfc_add_block_to_block (&block, &body1); /* Increment count1. */ - tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1, - gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1), + count1, gfc_index_one_node); gfc_add_modify (&block, count1, tmp); } else { /* Increment count1. */ - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - count1, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + count1, gfc_index_one_node); gfc_add_modify (&body1, count1, tmp); /* Increment count3. */ if (count3) { - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - count3, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + count3, gfc_index_one_node); gfc_add_modify (&body1, count3, tmp); } @@ -2479,11 +2718,13 @@ compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2, /* Figure out how many elements we need. */ for (i = 0; i < loop.dimen; i++) { - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - gfc_index_one_node, loop.from[i]); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - tmp, loop.to[i]); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_index_one_node, loop.from[i]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, loop.to[i]); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, tmp); } gfc_add_block_to_block (pblock, &loop.pre); size = gfc_evaluate_now (size, pblock); @@ -2521,8 +2762,9 @@ compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size, && !forall_tmp->mask && INTEGER_CST_P (forall_tmp->size)) { - inner_size = fold_build2 (MULT_EXPR, gfc_array_index_type, - inner_size, forall_tmp->size); + inner_size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + inner_size, forall_tmp->size); forall_tmp = forall_tmp->prev_nest; } @@ -2539,8 +2781,8 @@ compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size, if (inner_size_body) gfc_add_block_to_block (&body, inner_size_body); if (forall_tmp) - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - number, inner_size); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, number, inner_size); else tmp = inner_size; gfc_add_modify (&body, number, tmp); @@ -2569,7 +2811,8 @@ allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block, unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type)); if (!integer_onep (unit)) - bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size, unit); + bytesize = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, unit); else bytesize = size; @@ -2771,8 +3014,8 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, gfc_add_block_to_block (&body, &rse.post); /* Increment count. */ - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - count, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + count, gfc_index_one_node); gfc_add_modify (&body, count, tmp); tmp = gfc_finish_block (&body); @@ -2795,8 +3038,8 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, gfc_add_modify (&body, lse.expr, rse.expr); gfc_add_block_to_block (&body, &lse.post); /* Increment count. */ - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - count, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + count, gfc_index_one_node); gfc_add_modify (&body, count, tmp); tmp = gfc_finish_block (&body); @@ -2822,7 +3065,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, /* Make a new descriptor. */ parmtype = gfc_get_element_type (TREE_TYPE (desc)); - parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, + parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0, loop.from, loop.to, 1, GFC_ARRAY_UNKNOWN, true); @@ -2840,8 +3083,8 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, gfc_add_block_to_block (&body, &lse.post); /* Increment count. */ - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - count, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + count, gfc_index_one_node); gfc_add_modify (&body, count, tmp); tmp = gfc_finish_block (&body); @@ -2864,8 +3107,8 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, gfc_add_block_to_block (&body, &lse.post); /* Increment count. */ - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - count, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + count, gfc_index_one_node); gfc_add_modify (&body, count, tmp); tmp = gfc_finish_block (&body); @@ -3041,14 +3284,16 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) for (n = 0; n < nvar; n++) { /* size = (end + step - start) / step. */ - tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (start[n]), - step[n], start[n]); - tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp); - - tmp = fold_build2 (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]); + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]), + step[n], start[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]), + end[n], tmp); + tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp), + tmp, step[n]); tmp = convert (gfc_array_index_type, tmp); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, tmp); } /* Record the nvar and size of current forall level. */ @@ -3115,8 +3360,8 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) gfc_add_modify (&body, tmp, se.expr); /* Advance to the next mask element. */ - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - maskindex, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + maskindex, gfc_index_one_node); gfc_add_modify (&body, maskindex, tmp); /* Generate the loops. */ @@ -3323,7 +3568,7 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info, { tmp = gfc_build_array_ref (mask, count, NULL); if (invert) - tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, tmp); + tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp); gfc_add_modify (&body1, mtmp, tmp); } @@ -3332,16 +3577,18 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info, tmp1 = gfc_build_array_ref (cmask, count, NULL); tmp = cond; if (mask) - tmp = fold_build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp); + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, + mtmp, tmp); gfc_add_modify (&body1, tmp1, tmp); } if (pmask) { tmp1 = gfc_build_array_ref (pmask, count, NULL); - tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, cond); + tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond); if (mask) - tmp = fold_build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp); + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp, + tmp); gfc_add_modify (&body1, tmp1, tmp); } @@ -3355,8 +3602,8 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info, else { /* Increment count. */ - tmp1 = fold_build2 (PLUS_EXPR, gfc_array_index_type, count, - gfc_index_one_node); + tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + count, gfc_index_one_node); gfc_add_modify (&body1, count, tmp1); /* Generate the copying loops. */ @@ -3504,7 +3751,8 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, index = count1; maskexpr = gfc_build_array_ref (mask, index, NULL); if (invert) - maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr); + maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, + TREE_TYPE (maskexpr), maskexpr); /* Use the scalar assignment as is. */ tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, @@ -3517,8 +3765,8 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, if (lss == gfc_ss_terminator) { /* Increment count1. */ - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - count1, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + count1, gfc_index_one_node); gfc_add_modify (&body, count1, tmp); /* Use the scalar assignment as is. */ @@ -3533,8 +3781,8 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, { /* Increment count1 before finish the main body of a scalarized expression. */ - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - count1, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, count1, gfc_index_one_node); gfc_add_modify (&body, count1, tmp); gfc_trans_scalarized_loop_boundary (&loop, &body); @@ -3558,8 +3806,8 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, index = count2; maskexpr = gfc_build_array_ref (mask, index, NULL); if (invert) - maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), - maskexpr); + maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, + TREE_TYPE (maskexpr), maskexpr); /* Use the scalar assignment as is. */ tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false, @@ -3569,15 +3817,17 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_add_expr_to_block (&body, tmp); /* Increment count2. */ - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - count2, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, count2, + gfc_index_one_node); gfc_add_modify (&body, count2, tmp); } else { /* Increment count1. */ - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - count1, gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, count1, + gfc_index_one_node); gfc_add_modify (&body, count1, tmp); } @@ -3679,10 +3929,10 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, &inner_size_body, block); /* Check whether the size is negative. */ - cond = fold_build2 (LE_EXPR, boolean_type_node, size, - gfc_index_zero_node); - size = fold_build3 (COND_EXPR, gfc_array_index_type, cond, - gfc_index_zero_node, size); + cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, size, + gfc_index_zero_node); + size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, + cond, gfc_index_zero_node, size); size = gfc_evaluate_now (size, block); /* Allocate temporary for WHERE mask if needed. */ @@ -4067,7 +4317,9 @@ gfc_trans_cycle (gfc_code * code) { tree cycle_label; - cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl); + cycle_label = code->ext.which_construct->cycle_label; + gcc_assert (cycle_label); + TREE_USED (cycle_label) = 1; return build1_v (GOTO_EXPR, cycle_label); } @@ -4082,7 +4334,9 @@ gfc_trans_exit (gfc_code * code) { tree exit_label; - exit_label = TREE_VALUE (code->ext.whichloop->backend_decl); + exit_label = code->ext.which_construct->exit_label; + gcc_assert (exit_label); + TREE_USED (exit_label) = 1; return build1_v (GOTO_EXPR, exit_label); } @@ -4142,20 +4396,23 @@ gfc_trans_allocate (gfc_code * code) /* A scalar or derived type. */ /* Determine allocate size. */ - if (code->expr3 && code->expr3->ts.type == BT_CLASS) + if (al->expr->ts.type == BT_CLASS && code->expr3) { - gfc_expr *sz; - gfc_se se_sz; - sz = gfc_copy_expr (code->expr3); - gfc_add_component_ref (sz, "$vptr"); - gfc_add_component_ref (sz, "$size"); - gfc_init_se (&se_sz, NULL); - gfc_conv_expr (&se_sz, sz); - gfc_free_expr (sz); - memsz = se_sz.expr; + if (code->expr3->ts.type == BT_CLASS) + { + gfc_expr *sz; + gfc_se se_sz; + sz = gfc_copy_expr (code->expr3); + gfc_add_component_ref (sz, "$vptr"); + gfc_add_component_ref (sz, "$size"); + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, sz); + gfc_free_expr (sz); + memsz = se_sz.expr; + } + else + memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); } - else if (code->expr3 && code->expr3->ts.type != BT_CLASS) - memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); else if (code->ext.alloc.ts.type != BT_UNKNOWN) memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); else @@ -4190,17 +4447,20 @@ gfc_trans_allocate (gfc_code * code) tmp = gfc_allocate_with_status (&se.pre, memsz, pstat); } - tmp = fold_build2 (MODIFY_EXPR, void_type_node, se.expr, - fold_convert (TREE_TYPE (se.expr), tmp)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + se.expr, + fold_convert (TREE_TYPE (se.expr), tmp)); gfc_add_expr_to_block (&se.pre, tmp); if (code->expr1 || code->expr2) { tmp = build1_v (GOTO_EXPR, error_label); - parm = fold_build2 (NE_EXPR, boolean_type_node, - stat, build_int_cst (TREE_TYPE (stat), 0)); - tmp = fold_build3 (COND_EXPR, void_type_node, - parm, tmp, build_empty_stmt (input_location)); + parm = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, stat, + build_int_cst (TREE_TYPE (stat), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + parm, tmp, + build_empty_stmt (input_location)); gfc_add_expr_to_block (&se.pre, tmp); } @@ -4216,9 +4476,10 @@ gfc_trans_allocate (gfc_code * code) tmp = gfc_finish_block (&se.pre); gfc_add_expr_to_block (&block, tmp); - /* Initialization via SOURCE block. */ - if (code->expr3) + if (code->expr3 && !code->expr3->mold) { + /* Initialization via SOURCE block + (or static default initializer). */ gfc_expr *rhs = gfc_copy_expr (code->expr3); if (al->expr->ts.type == BT_CLASS) { @@ -4238,6 +4499,23 @@ gfc_trans_allocate (gfc_code * code) gfc_free_expr (rhs); gfc_add_expr_to_block (&block, tmp); } + else if (code->expr3 && code->expr3->mold + && code->expr3->ts.type == BT_CLASS) + { + /* Default-initialization via MOLD (polymorphic). */ + gfc_expr *rhs = gfc_copy_expr (code->expr3); + gfc_se dst,src; + gfc_add_component_ref (rhs, "$vptr"); + gfc_add_component_ref (rhs, "$def_init"); + gfc_init_se (&dst, NULL); + gfc_init_se (&src, NULL); + gfc_conv_expr (&dst, expr); + gfc_conv_expr (&src, rhs); + gfc_add_block_to_block (&block, &src.pre); + tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz); + gfc_add_expr_to_block (&block, tmp); + gfc_free_expr (rhs); + } /* Allocation of CLASS entities. */ gfc_free_expr (expr); @@ -4253,7 +4531,7 @@ gfc_trans_allocate (gfc_code * code) rhs = NULL; if (code->expr3 && code->expr3->ts.type == BT_CLASS) { - /* VPTR must be determined at run time. */ + /* Polymorphic SOURCE: VPTR must be determined at run time. */ rhs = gfc_copy_expr (code->expr3); gfc_add_component_ref (rhs, "$vptr"); tmp = gfc_trans_pointer_assignment (lhs, rhs); @@ -4272,7 +4550,7 @@ gfc_trans_allocate (gfc_code * code) else if (code->ext.alloc.ts.type == BT_DERIVED) ts = &code->ext.alloc.ts; else if (expr->ts.type == BT_CLASS) - ts = &expr->ts.u.derived->components->ts; + ts = &CLASS_DATA (expr)->ts; else ts = &expr->ts; @@ -4323,14 +4601,15 @@ gfc_trans_allocate (gfc_code * code) slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg))); dlen = gfc_get_expr_charlen (code->expr2); - slen = fold_build2 (MIN_EXPR, TREE_TYPE (slen), dlen, slen); + slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen, + slen); dlen = build_call_expr_loc (input_location, built_in_decls[BUILT_IN_MEMCPY], 3, gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen); - tmp = fold_build2 (NE_EXPR, boolean_type_node, stat, - build_int_cst (TREE_TYPE (stat), 0)); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, + build_int_cst (TREE_TYPE (stat), 0)); tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location)); @@ -4412,8 +4691,9 @@ gfc_trans_deallocate (gfc_code *code) tmp = gfc_deallocate_with_status (se.expr, pstat, false, expr); gfc_add_expr_to_block (&se.pre, tmp); - tmp = fold_build2 (MODIFY_EXPR, void_type_node, - se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + se.expr, + build_int_cst (TREE_TYPE (se.expr), 0)); } gfc_add_expr_to_block (&se.pre, tmp); @@ -4422,7 +4702,8 @@ gfc_trans_deallocate (gfc_code *code) of the last deallocation to the running total. */ if (code->expr1 || code->expr2) { - apstat = fold_build2 (PLUS_EXPR, TREE_TYPE (stat), astat, stat); + apstat = fold_build2_loc (input_location, PLUS_EXPR, + TREE_TYPE (stat), astat, stat); gfc_add_modify (&se.pre, astat, apstat); } @@ -4458,14 +4739,15 @@ gfc_trans_deallocate (gfc_code *code) slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg))); dlen = gfc_get_expr_charlen (code->expr2); - slen = fold_build2 (MIN_EXPR, TREE_TYPE (slen), dlen, slen); + slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen, + slen); dlen = build_call_expr_loc (input_location, built_in_decls[BUILT_IN_MEMCPY], 3, gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen); - tmp = fold_build2 (NE_EXPR, boolean_type_node, astat, - build_int_cst (TREE_TYPE (astat), 0)); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, astat, + build_int_cst (TREE_TYPE (astat), 0)); tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location)); @@ -4475,3 +4757,4 @@ gfc_trans_deallocate (gfc_code *code) return gfc_finish_block (&block); } +#include "gt-fortran-trans-stmt.h" diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index b3495456462..8b77750c589 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -32,7 +32,8 @@ tree gfc_trans_code_cond (gfc_code *, tree); tree gfc_trans_assign (gfc_code *); tree gfc_trans_pointer_assign (gfc_code *); tree gfc_trans_init_assign (gfc_code *); -tree gfc_trans_class_assign (gfc_code *code); +tree gfc_trans_class_init_assign (gfc_code *); +tree gfc_trans_class_assign (gfc_expr *, gfc_expr *, gfc_exec_op); /* trans-stmt.c */ tree gfc_trans_cycle (gfc_code *); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index e359a480c71..7933a941d94 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -27,18 +27,17 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "langhooks.h" -#include "tm.h" +#include "langhooks.h" /* For iso-c-bindings.def. */ #include "target.h" #include "ggc.h" -#include "toplev.h" +#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" #include "trans-const.h" -#include "real.h" #include "flags.h" -#include "dwarf2out.h" +#include "dwarf2out.h" /* For struct array_descr_info. */ #if (GFC_MAX_DIMENSIONS < 10) @@ -65,6 +64,11 @@ tree pfunc_type_node; tree gfc_charlen_type_node; +tree float128_type_node = NULL_TREE; +tree complex_float128_type_node = NULL_TREE; + +bool gfc_real16_is_float128 = false; + static GTY(()) tree gfc_desc_dim_type; static GTY(()) tree gfc_max_array_element_size; static GTY(()) tree gfc_array_descriptor_base[2 * GFC_MAX_DIMENSIONS]; @@ -88,6 +92,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. */ @@ -403,10 +408,11 @@ gfc_init_kinds (void) if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode)) continue; - /* Only let float/double/long double go through because the fortran - library assumes these are the only floating point types. */ - - if (mode != TYPE_MODE (float_type_node) + /* Only let float, double, long double and __float128 go through. + Runtime support for others is not provided, so they would be + useless. TODO: TFmode support should be enabled once libgfortran + support is done. */ + if (mode != TYPE_MODE (float_type_node) && (mode != TYPE_MODE (double_type_node)) && (mode != TYPE_MODE (long_double_type_node))) continue; @@ -711,6 +717,11 @@ gfc_build_real_type (gfc_real_info *info) info->c_double = 1; if (mode_precision == LONG_DOUBLE_TYPE_SIZE) info->c_long_double = 1; + if (mode_precision != LONG_DOUBLE_TYPE_SIZE && mode_precision == 128) + { + info->c_float128 = 1; + gfc_real16_is_float128 = true; + } if (TYPE_PRECISION (float_type_node) == mode_precision) return float_type_node; @@ -835,11 +846,17 @@ gfc_init_types (void) gfc_real_kinds[index].kind); PUSH_TYPE (name_buf, type); + if (gfc_real_kinds[index].c_float128) + float128_type_node = type; + type = gfc_build_complex_type (type); gfc_complex_types[index] = type; snprintf (name_buf, sizeof(name_buf), "complex(kind=%d)", gfc_real_kinds[index].kind); PUSH_TYPE (name_buf, type); + + if (gfc_real_kinds[index].c_float128) + complex_float128_type_node = type; } for (index = 0; gfc_character_kinds[index].kind != 0; ++index) @@ -870,7 +887,7 @@ gfc_init_types (void) ppvoid_type_node = build_pointer_type (pvoid_type_node); pchar_type_node = build_pointer_type (gfc_character1_type_node); pfunc_type_node - = build_pointer_type (build_function_type (void_type_node, NULL_TREE)); + = build_pointer_type (build_function_type_list (void_type_node, NULL_TREE)); gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind); /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type, @@ -1183,13 +1200,13 @@ gfc_is_nodesc_array (gfc_symbol * sym) if (sym->attr.pointer || sym->attr.allocatable) return 0; + /* We want a descriptor for associate-name arrays that do not have an + explicitely known shape already. */ + if (sym->assoc && sym->as->type != AS_EXPLICIT) + return 0; + if (sym->attr.dummy) - { - if (sym->as->type != AS_ASSUMED_SHAPE) - return 1; - else - return 0; - } + return sym->as->type != AS_ASSUMED_SHAPE; if (sym->attr.result || sym->attr.function) return 0; @@ -1204,7 +1221,8 @@ gfc_is_nodesc_array (gfc_symbol * sym) static tree gfc_build_array_type (tree type, gfc_array_spec * as, - enum gfc_array_kind akind, bool restricted) + enum gfc_array_kind akind, bool restricted, + bool contiguous) { tree lbound[GFC_MAX_DIMENSIONS]; tree ubound[GFC_MAX_DIMENSIONS]; @@ -1221,9 +1239,10 @@ gfc_build_array_type (tree type, gfc_array_spec * as, } if (as->type == AS_ASSUMED_SHAPE) - akind = GFC_ARRAY_ASSUMED_SHAPE; - return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0, akind, - restricted); + akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT + : GFC_ARRAY_ASSUMED_SHAPE; + return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound, + ubound, 0, akind, restricted); } /* Returns the struct descriptor_dimension type. */ @@ -1232,8 +1251,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 +1263,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; @@ -1350,9 +1360,11 @@ gfc_get_dtype (tree type) if (size && !INTEGER_CST_P (size)) { tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT); - tmp = fold_build2 (LSHIFT_EXPR, gfc_array_index_type, - fold_convert (gfc_array_index_type, size), tmp); - dtype = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype); + tmp = fold_build2_loc (input_location, LSHIFT_EXPR, + gfc_array_index_type, + fold_convert (gfc_array_index_type, size), tmp); + dtype = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + tmp, dtype); } /* If we don't know the size we leave it as zero. This should never happen for anything that is actually used. */ @@ -1392,8 +1404,8 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, type = make_node (ARRAY_TYPE); GFC_ARRAY_TYPE_P (type) = 1; - TYPE_LANG_SPECIFIC (type) = (struct lang_type *) - ggc_alloc_cleared (sizeof (struct lang_type)); + TYPE_LANG_SPECIFIC (type) + = ggc_alloc_cleared_lang_type (sizeof (struct lang_type)); known_stride = (packed != PACKED_NO); known_offset = 1; @@ -1538,62 +1550,55 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, /* Return or create the base type for an array descriptor. */ static tree -gfc_get_array_descriptor_base (int dimen, bool restricted) +gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted) { - tree fat_type, fieldlist, decl, arraytype; - char name[16 + GFC_RANK_DIGITS + 1]; - int idx = 2 * (dimen - 1) + restricted; + tree fat_type, decl, arraytype, *chain = NULL; + char name[16 + 2*GFC_RANK_DIGITS + 1 + 1]; + int idx = 2 * (codimen + dimen - 1) + restricted; - gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS); + gcc_assert (dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS); if (gfc_array_descriptor_base[idx]) return gfc_array_descriptor_base[idx]; /* Build the type node. */ fat_type = make_node (RECORD_TYPE); - sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen); + 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 = build_array_type (gfc_get_desc_dim_type (), build_range_type (gfc_array_index_type, gfc_index_zero_node, - gfc_rank_cst[dimen - 1])); + 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; @@ -1604,20 +1609,20 @@ gfc_get_array_descriptor_base (int dimen, bool restricted) /* Build an array (descriptor) type with given bounds. */ tree -gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound, +gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound, tree * ubound, int packed, enum gfc_array_kind akind, bool restricted) { - char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN]; + char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN]; tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype; const char *type_name; int n; - base_type = gfc_get_array_descriptor_base (dimen, restricted); + base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted); fat_type = build_distinct_type_copy (base_type); /* Make sure that nontarget and target array type have the same canonical type (and same stub decl for debug info). */ - base_type = gfc_get_array_descriptor_base (dimen, false); + base_type = gfc_get_array_descriptor_base (dimen, codimen, false); TYPE_CANONICAL (fat_type) = base_type; TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type); @@ -1628,13 +1633,14 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound, type_name = IDENTIFIER_POINTER (tmp); else type_name = "unknown"; - sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen, + 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) = (struct lang_type *) - ggc_alloc_cleared (sizeof (struct lang_type)); + TYPE_LANG_SPECIFIC (fat_type) + = ggc_alloc_cleared_lang_type (sizeof (struct lang_type)); GFC_TYPE_ARRAY_RANK (fat_type) = dimen; GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE; @@ -1673,11 +1679,13 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound, if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE) { - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, - gfc_index_one_node); - stride = - fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, upper, lower); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); + stride = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, stride); /* Check the folding worked. */ gcc_assert (INTEGER_CST_P (stride)); } @@ -1793,22 +1801,28 @@ gfc_sym_type (gfc_symbol * sym) restricted); byref = 0; } + + if (sym->attr.cray_pointee) + GFC_POINTER_TYPE_P (type) = 1; } else { enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN; if (sym->attr.pointer) - akind = GFC_ARRAY_POINTER; + akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT + : GFC_ARRAY_POINTER; else if (sym->attr.allocatable) akind = GFC_ARRAY_ALLOCATABLE; - type = gfc_build_array_type (type, sym->as, akind, restricted); + type = gfc_build_array_type (type, sym->as, akind, restricted, + sym->attr.contiguous); } } else { - if (sym->attr.allocatable || sym->attr.pointer) + if (sym->attr.allocatable || sym->attr.pointer + || gfc_is_associate_pointer (sym)) type = gfc_build_pointer_type (sym, type); - if (sym->attr.pointer) + if (sym->attr.pointer || sym->attr.cray_pointee) GFC_POINTER_TYPE_P (type) = 1; } @@ -1848,26 +1862,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; } @@ -1877,8 +1906,8 @@ gfc_add_field_to_struct (tree *fieldlist, tree context, the two derived type symbols are "equal", as described in 4.4.2 and resolved by gfc_compare_derived_types. */ -static int -copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to, +int +gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to, bool from_gsym) { gfc_component *to_cm; @@ -1931,7 +1960,7 @@ gfc_get_ppc_type (gfc_component* c) else t = void_type_node; - return build_pointer_type (build_function_type (t, NULL_TREE)); + return build_pointer_type (build_function_type_list (t, NULL_TREE)); } @@ -1943,8 +1972,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; @@ -1964,14 +1994,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 @@ -1994,9 +2016,11 @@ gfc_get_derived_type (gfc_symbol * derived) gfc_symbol *s; s = NULL; gfc_find_symbol (derived->name, gsym->ns, 0, &s); - if (s && s->backend_decl) + if (s) { - copy_dt_decls_ifequal (s, derived, true); + if (!s->backend_decl) + s->backend_decl = gfc_get_derived_type (s); + gfc_copy_dt_decls_ifequal (s, derived, true); goto copy_derived_types; } } @@ -2016,7 +2040,7 @@ gfc_get_derived_type (gfc_symbol * derived) dt = ns->derived_types; for (; dt && !canonical; dt = dt->next) { - copy_dt_decls_ifequal (dt->derived, derived, true); + gfc_copy_dt_decls_ifequal (dt->derived, derived, true); if (derived->backend_decl) got_canonical = true; } @@ -2093,7 +2117,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) @@ -2120,14 +2143,16 @@ gfc_get_derived_type (gfc_symbol * derived) { enum gfc_array_kind akind; if (c->attr.pointer) - akind = GFC_ARRAY_POINTER; + akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT + : GFC_ARRAY_POINTER; else akind = GFC_ARRAY_ALLOCATABLE; /* Pointers to arrays aren't actually pointer types. The descriptors are separate, but the data is common. */ field_type = gfc_build_array_type (field_type, c->as, akind, !c->attr.target - && !c->attr.pointer); + && !c->attr.pointer, + c->attr.contiguous); } else field_type = gfc_get_nodesc_array_type (field_type, c->as, @@ -2138,8 +2163,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) @@ -2152,9 +2183,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; @@ -2178,7 +2207,7 @@ gfc_get_derived_type (gfc_symbol * derived) copy_derived_types: for (dt = gfc_derived_types; dt; dt = dt->next) - copy_dt_decls_ifequal (derived, dt->derived, false); + gfc_copy_dt_decls_ifequal (derived, dt->derived, false); return derived->backend_decl; } @@ -2217,8 +2246,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; @@ -2231,7 +2259,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) { @@ -2241,24 +2268,64 @@ 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; } +/* Create a "fn spec" based on the formal arguments; + cf. create_function_arglist. */ + +static tree +create_fn_spec (gfc_symbol *sym, tree fntype) +{ + char spec[150]; + size_t spec_len; + gfc_formal_arglist *f; + tree tmp; + + memset (&spec, 0, sizeof (spec)); + spec[0] = '.'; + spec_len = 1; + + if (sym->attr.entry_master) + spec[spec_len++] = 'R'; + if (gfc_return_by_reference (sym)) + { + gfc_symbol *result = sym->result ? sym->result : sym; + + if (result->attr.pointer || sym->attr.proc_pointer) + spec[spec_len++] = '.'; + else + spec[spec_len++] = 'w'; + if (sym->ts.type == BT_CHARACTER) + spec[spec_len++] = 'R'; + } + + for (f = sym->formal; f; f = f->next) + if (spec_len < sizeof (spec)) + { + if (!f->sym || f->sym->attr.pointer || f->sym->attr.target + || f->sym->attr.external || f->sym->attr.cray_pointer) + spec[spec_len++] = '.'; + else if (f->sym->attr.intent == INTENT_IN) + spec[spec_len++] = 'r'; + else if (f->sym) + spec[spec_len++] = 'w'; + } + + tmp = build_tree_list (NULL_TREE, build_string (spec_len, spec)); + tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (fntype)); + return build_type_attribute_variant (fntype, tmp); +} + + tree gfc_get_function_type (gfc_symbol * sym) { @@ -2358,7 +2425,9 @@ gfc_get_function_type (gfc_symbol * sym) typelist = gfc_chainon_list (typelist, gfc_charlen_type_node); if (typelist) - typelist = gfc_chainon_list (typelist, void_type_node); + typelist = chainon (typelist, void_list_node); + else if (sym->attr.is_main_program) + typelist = void_list_node; if (alternate_return) type = integer_type_node; @@ -2398,6 +2467,7 @@ gfc_get_function_type (gfc_symbol * sym) type = gfc_sym_type (sym); type = build_function_type (type, typelist); + type = create_fn_spec (sym, type); return type; } @@ -2515,7 +2585,8 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) if (int_size_in_bytes (etype) <= 0) return false; /* Nor non-constant lower bounds in assumed shape arrays. */ - if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE) + if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT) { for (dim = 0; dim < rank; dim++) if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE @@ -2544,16 +2615,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; @@ -2564,7 +2635,8 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) info->allocated = build2 (NE_EXPR, boolean_type_node, info->data_location, null_pointer_node); - else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER) + else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT) info->associated = build2 (NE_EXPR, boolean_type_node, info->data_location, null_pointer_node); @@ -2578,7 +2650,8 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) size_binop (PLUS_EXPR, dim_off, upper_suboff)); t = build1 (INDIRECT_REF, gfc_array_index_type, t); info->dimen[dim].upper_bound = t; - if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE) + if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT) { /* Assumed shape arrays have known lower bounds. */ info->dimen[dim].upper_bound diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 87feea3dfaf..1741b9bf660 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -31,6 +31,8 @@ extern GTY(()) tree ppvoid_type_node; extern GTY(()) tree pvoid_type_node; extern GTY(()) tree prvoid_type_node; extern GTY(()) tree pchar_type_node; +extern GTY(()) tree float128_type_node; +extern GTY(()) tree complex_float128_type_node; /* This is the type used to hold the lengths of character variables. It must be the same as the corresponding definition in gfortran.h. */ @@ -38,6 +40,11 @@ extern GTY(()) tree pchar_type_node; and runtime library. */ extern GTY(()) tree gfc_charlen_type_node; +/* The following flags give us information on the correspondance of + real (and complex) kinds with C floating-point types long double + and __float128. */ +extern bool gfc_real16_is_float128; + typedef enum { PACKED_NO = 0, PACKED_PARTIAL, @@ -64,6 +71,7 @@ tree gfc_get_character_type_len_for_eltype (tree, tree); tree gfc_sym_type (gfc_symbol *); tree gfc_typenode_for_spec (gfc_typespec *); +int gfc_copy_dt_decls_ifequal (gfc_symbol *, gfc_symbol *, bool); tree gfc_get_function_type (gfc_symbol *); @@ -72,12 +80,12 @@ tree gfc_type_for_mode (enum machine_mode, int); tree gfc_build_uint_type (int); tree gfc_get_element_type (tree); -tree gfc_get_array_type_bounds (tree, int, tree *, tree *, int, +tree gfc_get_array_type_bounds (tree, int, int, tree *, tree *, int, enum gfc_array_kind, bool); 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 c1993f90ddd..a608fb12252 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -23,12 +23,10 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "gimple.h" +#include "gimple.h" /* For create_tmp_var_raw. */ #include "tree-iterator.h" -#include "ggc.h" -#include "toplev.h" +#include "diagnostic-core.h" /* For internal_error. */ #include "defaults.h" -#include "real.h" #include "flags.h" #include "gfortran.h" #include "trans.h" @@ -47,7 +45,6 @@ along with GCC; see the file COPYING3. If not see static gfc_file *gfc_current_backend_file; -const char gfc_msg_bounds[] = N_("Array bound mismatch"); const char gfc_msg_fault[] = N_("Array reference out of bounds"); const char gfc_msg_wrong_return[] = N_("Incorrect function return value"); @@ -60,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; } @@ -170,7 +167,8 @@ gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs) || AGGREGATE_TYPE_P (TREE_TYPE (lhs))); #endif - tmp = fold_build2 (MODIFY_EXPR, void_type_node, lhs, rhs); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, lhs, + rhs); gfc_add_expr_to_block (pblock, tmp); } @@ -221,8 +219,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; @@ -280,8 +278,8 @@ gfc_build_addr_expr (tree type, tree t) tree type_domain = TYPE_DOMAIN (base_type); if (type_domain && TYPE_MIN_VALUE (type_domain)) min_val = TYPE_MIN_VALUE (type_domain); - t = fold (build4 (ARRAY_REF, TREE_TYPE (type), - t, min_val, NULL_TREE, NULL_TREE)); + t = fold (build4_loc (input_location, ARRAY_REF, TREE_TYPE (type), + t, min_val, NULL_TREE, NULL_TREE)); natural_type = type; } else @@ -299,7 +297,7 @@ gfc_build_addr_expr (tree type, tree t) tree base = get_base_address (t); if (base && DECL_P (base)) TREE_ADDRESSABLE (base) = 1; - t = fold_build1 (ADDR_EXPR, natural_type, t); + t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t); } if (type && natural_type != type) @@ -335,11 +333,13 @@ gfc_build_array_ref (tree base, tree offset, tree decl) && GFC_DECL_SUBREF_ARRAY_P (decl) && !integer_zerop (GFC_DECL_SPAN(decl))) { - offset = fold_build2 (MULT_EXPR, gfc_array_index_type, - offset, GFC_DECL_SPAN(decl)); + offset = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + offset, GFC_DECL_SPAN(decl)); tmp = gfc_build_addr_expr (pvoid_type_node, base); - tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node, - tmp, fold_convert (sizetype, offset)); + tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR, + pvoid_type_node, tmp, + fold_convert (sizetype, offset)); tmp = fold_convert (build_pointer_type (type), tmp); if (!TYPE_STRING_FLAG (type)) tmp = build_fold_indirect_ref_loc (input_location, tmp); @@ -347,7 +347,8 @@ gfc_build_array_ref (tree base, tree offset, tree decl) } else /* Otherwise use a straightforward array reference. */ - return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE); + return build4_loc (input_location, ARRAY_REF, type, base, offset, + NULL_TREE, NULL_TREE); } @@ -408,7 +409,7 @@ gfc_trans_runtime_error_vararg (bool error, locus* where, const char* msgid, gfc_free(message); /* Build the argument array. */ - argarray = (tree *) alloca (sizeof (tree) * (nargs + 2)); + argarray = XALLOCAVEC (tree, nargs + 2); argarray[0] = arg; argarray[1] = arg2; for (i = 0; i < nargs; i++) @@ -424,11 +425,11 @@ gfc_trans_runtime_error_vararg (bool error, locus* where, const char* msgid, fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at); tmp = fold_builtin_call_array (input_location, TREE_TYPE (fntype), - fold_build1 (ADDR_EXPR, - build_pointer_type (fntype), - error - ? gfor_fndecl_runtime_error_at - : gfor_fndecl_runtime_warning_at), + fold_build1_loc (input_location, ADDR_EXPR, + build_pointer_type (fntype), + error + ? gfor_fndecl_runtime_error_at + : gfor_fndecl_runtime_warning_at), nargs + 2, argarray); gfc_add_expr_to_block (&block, tmp); @@ -480,8 +481,8 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock, { /* Tell the compiler that this isn't likely. */ if (once) - cond = fold_build2 (TRUTH_AND_EXPR, long_integer_type_node, tmpvar, - cond); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, + long_integer_type_node, tmpvar, cond); else cond = fold_convert (long_integer_type_node, cond); @@ -516,8 +517,8 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size) /* Call malloc. */ gfc_start_block (&block2); - size = fold_build2 (MAX_EXPR, size_type_node, size, - build_int_cst (size_type_node, 1)); + size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size, + build_int_cst (size_type_node, 1)); gfc_add_modify (&block2, res, fold_convert (prvoid_type_node, @@ -527,11 +528,13 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size) /* Optionally check whether malloc was successful. */ if (gfc_option.rtcheck & GFC_RTCHECK_MEM) { - null_result = fold_build2 (EQ_EXPR, boolean_type_node, res, - build_int_cst (pvoid_type_node, 0)); + null_result = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, res, + build_int_cst (pvoid_type_node, 0)); msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const ("Memory allocation failed")); - tmp = fold_build3 (COND_EXPR, void_type_node, null_result, + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + null_result, build_call_expr_loc (input_location, gfor_fndecl_os_error, 1, msg), build_empty_stmt (input_location)); @@ -604,13 +607,15 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status) /* Set the optional status variable to zero. */ if (status != NULL_TREE && !integer_zerop (status)) { - tmp = fold_build2 (MODIFY_EXPR, status_type, - fold_build1 (INDIRECT_REF, status_type, status), - build_int_cst (status_type, 0)); - tmp = fold_build3 (COND_EXPR, void_type_node, - fold_build2 (NE_EXPR, boolean_type_node, status, - build_int_cst (TREE_TYPE (status), 0)), - tmp, build_empty_stmt (input_location)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), + build_int_cst (status_type, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, status, + build_int_cst (TREE_TYPE (status), 0)), + tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); } @@ -628,15 +633,16 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status) gfc_start_block (&set_status_block); gfc_add_modify (&set_status_block, - fold_build1 (INDIRECT_REF, status_type, status), + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), build_int_cst (status_type, LIBERROR_ALLOCATION)); gfc_add_modify (&set_status_block, res, build_int_cst (prvoid_type_node, 0)); - tmp = fold_build2 (EQ_EXPR, boolean_type_node, status, - build_int_cst (TREE_TYPE (status), 0)); - error = fold_build3 (COND_EXPR, void_type_node, tmp, error, - gfc_finish_block (&set_status_block)); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + status, build_int_cst (TREE_TYPE (status), 0)); + error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, + error, gfc_finish_block (&set_status_block)); } /* The allocation itself. */ @@ -645,9 +651,10 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status) fold_convert (prvoid_type_node, build_call_expr_loc (input_location, built_in_decls[BUILT_IN_MALLOC], 1, - fold_build2 (MAX_EXPR, size_type_node, - size, - build_int_cst (size_type_node, 1))))); + fold_build2_loc (input_location, + MAX_EXPR, size_type_node, size, + build_int_cst (size_type_node, + 1))))); msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const ("Out of memory")); @@ -659,25 +666,27 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status) /* Set the status variable if it's present. */ tree tmp2; - cond = fold_build2 (EQ_EXPR, boolean_type_node, status, - build_int_cst (TREE_TYPE (status), 0)); - tmp2 = fold_build2 (MODIFY_EXPR, status_type, - fold_build1 (INDIRECT_REF, status_type, status), - build_int_cst (status_type, LIBERROR_ALLOCATION)); - tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, - tmp2); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + status, build_int_cst (TREE_TYPE (status), 0)); + tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), + build_int_cst (status_type, LIBERROR_ALLOCATION)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, + tmp, tmp2); } - tmp = fold_build3 (COND_EXPR, void_type_node, - fold_build2 (EQ_EXPR, boolean_type_node, res, - build_int_cst (prvoid_type_node, 0)), - tmp, build_empty_stmt (input_location)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, res, + build_int_cst (prvoid_type_node, 0)), + tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&alloc_block, tmp); - cond = fold_build2 (LT_EXPR, boolean_type_node, size, - build_int_cst (TREE_TYPE (size), 0)); - tmp = fold_build3 (COND_EXPR, void_type_node, cond, error, - gfc_finish_block (&alloc_block)); + cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, size, + build_int_cst (TREE_TYPE (size), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, error, + gfc_finish_block (&alloc_block)); gfc_add_expr_to_block (block, tmp); return res; @@ -705,7 +714,7 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status) return mem; } else - runtime_error ("Attempting to allocate already allocated array"); + runtime_error ("Attempting to allocate already allocated variable"); } } @@ -724,8 +733,8 @@ gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size, /* Create a variable to hold the result. */ res = gfc_create_var (type, NULL); - null_mem = fold_build2 (EQ_EXPR, boolean_type_node, mem, - build_int_cst (type, 0)); + null_mem = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, mem, + build_int_cst (type, 0)); /* If mem is NULL, we call gfc_allocate_with_status. */ gfc_start_block (&alloc_block); @@ -744,13 +753,13 @@ gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size, error = gfc_trans_runtime_error (true, &expr->where, "Attempting to allocate already" - " allocated array '%s'", + " allocated variable '%s'", varname); } else error = gfc_trans_runtime_error (true, NULL, "Attempting to allocate already allocated" - "array"); + "variable"); if (status != NULL_TREE && !integer_zerop (status)) { @@ -767,16 +776,18 @@ gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size, gfc_add_modify (&set_status_block, res, fold_convert (type, tmp)); gfc_add_modify (&set_status_block, - fold_build1 (INDIRECT_REF, status_type, status), + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), build_int_cst (status_type, LIBERROR_ALLOCATION)); - tmp = fold_build2 (EQ_EXPR, boolean_type_node, status, - build_int_cst (status_type, 0)); - error = fold_build3 (COND_EXPR, void_type_node, tmp, error, - gfc_finish_block (&set_status_block)); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + status, build_int_cst (status_type, 0)); + error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, + error, gfc_finish_block (&set_status_block)); } - tmp = fold_build3 (COND_EXPR, void_type_node, null_mem, alloc, error); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem, + alloc, error); gfc_add_expr_to_block (block, tmp); return res; @@ -795,12 +806,12 @@ gfc_call_free (tree var) gfc_start_block (&block); var = gfc_evaluate_now (var, &block); - cond = fold_build2 (NE_EXPR, boolean_type_node, var, - build_int_cst (pvoid_type_node, 0)); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, var, + build_int_cst (pvoid_type_node, 0)); call = build_call_expr_loc (input_location, - built_in_decls[BUILT_IN_FREE], 1, var); - tmp = fold_build3 (COND_EXPR, void_type_node, cond, call, - build_empty_stmt (input_location)); + built_in_decls[BUILT_IN_FREE], 1, var); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, call, + build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); return gfc_finish_block (&block); @@ -844,8 +855,8 @@ gfc_deallocate_with_status (tree pointer, tree status, bool can_fail, stmtblock_t null, non_null; tree cond, tmp, error; - cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer, - build_int_cst (TREE_TYPE (pointer), 0)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, + build_int_cst (TREE_TYPE (pointer), 0)); /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise we emit a runtime error. */ @@ -871,12 +882,14 @@ gfc_deallocate_with_status (tree pointer, tree status, bool can_fail, tree status_type = TREE_TYPE (TREE_TYPE (status)); tree cond2; - cond2 = fold_build2 (NE_EXPR, boolean_type_node, status, - build_int_cst (TREE_TYPE (status), 0)); - tmp = fold_build2 (MODIFY_EXPR, status_type, - fold_build1 (INDIRECT_REF, status_type, status), - build_int_cst (status_type, 1)); - error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error); + cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + status, build_int_cst (TREE_TYPE (status), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), + build_int_cst (status_type, 1)); + error = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond2, tmp, error); } gfc_add_expr_to_block (&null, error); @@ -894,18 +907,20 @@ gfc_deallocate_with_status (tree pointer, tree status, bool can_fail, tree status_type = TREE_TYPE (TREE_TYPE (status)); tree cond2; - cond2 = fold_build2 (NE_EXPR, boolean_type_node, status, - build_int_cst (TREE_TYPE (status), 0)); - tmp = fold_build2 (MODIFY_EXPR, status_type, - fold_build1 (INDIRECT_REF, status_type, status), - build_int_cst (status_type, 0)); - tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, - build_empty_stmt (input_location)); + cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + status, build_int_cst (TREE_TYPE (status), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), + build_int_cst (status_type, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, + tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&non_null, tmp); } - return fold_build3 (COND_EXPR, void_type_node, cond, - gfc_finish_block (&null), gfc_finish_block (&non_null)); + return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, + gfc_finish_block (&null), + gfc_finish_block (&non_null)); } @@ -941,14 +956,14 @@ gfc_call_realloc (stmtblock_t * block, tree mem, tree size) res = gfc_create_var (type, NULL); /* size < 0 ? */ - negative = fold_build2 (LT_EXPR, boolean_type_node, size, - build_int_cst (size_type_node, 0)); + negative = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, size, + build_int_cst (size_type_node, 0)); msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const ("Attempt to allocate a negative amount of memory.")); - tmp = fold_build3 (COND_EXPR, void_type_node, negative, - build_call_expr_loc (input_location, - gfor_fndecl_runtime_error, 1, msg), - build_empty_stmt (input_location)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, negative, + build_call_expr_loc (input_location, + gfor_fndecl_runtime_error, 1, msg), + build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); /* Call realloc and check the result. */ @@ -956,55 +971,74 @@ gfc_call_realloc (stmtblock_t * block, tree mem, tree size) built_in_decls[BUILT_IN_REALLOC], 2, fold_convert (pvoid_type_node, mem), size); gfc_add_modify (block, res, fold_convert (type, tmp)); - null_result = fold_build2 (EQ_EXPR, boolean_type_node, res, - build_int_cst (pvoid_type_node, 0)); - nonzero = fold_build2 (NE_EXPR, boolean_type_node, size, - build_int_cst (size_type_node, 0)); - null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result, - nonzero); + null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + res, build_int_cst (pvoid_type_node, 0)); + nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size, + build_int_cst (size_type_node, 0)); + null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, + null_result, nonzero); msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const ("Out of memory")); - tmp = fold_build3 (COND_EXPR, void_type_node, null_result, - build_call_expr_loc (input_location, - gfor_fndecl_os_error, 1, msg), - build_empty_stmt (input_location)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + null_result, + build_call_expr_loc (input_location, + gfor_fndecl_os_error, 1, msg), + build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); /* if (size == 0) then the result is NULL. */ - tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0)); - zero = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, nonzero); - tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp, - build_empty_stmt (input_location)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, res, + build_int_cst (type, 0)); + zero = fold_build1_loc (input_location, TRUTH_NOT_EXPR, boolean_type_node, + nonzero); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, zero, tmp, + build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); 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); + } + + if (front) + { + tree_stmt_iterator i; + + i = tsi_start (*chain); + tsi_link_before (&i, expr, TSI_CONTINUE_LINKING); } - append_to_statement_list (expr, &block->head); + 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); } @@ -1068,6 +1102,8 @@ trans_code (gfc_code * code, tree cond) gfc_add_expr_to_block (&block, res); } + gfc_set_backend_locus (&code->loc); + switch (code->op) { case EXEC_NOP: @@ -1078,7 +1114,7 @@ trans_code (gfc_code * code, tree cond) case EXEC_ASSIGN: if (code->expr1->ts.type == BT_CLASS) - res = gfc_trans_class_assign (code); + res = gfc_trans_class_assign (code->expr1, code->expr2, code->op); else res = gfc_trans_assign (code); break; @@ -1089,14 +1125,14 @@ trans_code (gfc_code * code, tree cond) case EXEC_POINTER_ASSIGN: if (code->expr1->ts.type == BT_CLASS) - res = gfc_trans_class_assign (code); + res = gfc_trans_class_assign (code->expr1, code->expr2, code->op); else res = gfc_trans_pointer_assign (code); break; case EXEC_INIT_ASSIGN: if (code->expr1->ts.type == BT_CLASS) - res = gfc_trans_class_assign (code); + res = gfc_trans_class_init_assign (code); else res = gfc_trans_init_assign (code); break; @@ -1142,8 +1178,12 @@ trans_code (gfc_code * code, tree cond) if (code->resolved_isym && code->resolved_isym->id == GFC_ISYM_MVBITS) is_mvbits = true; - res = gfc_trans_call (code, is_mvbits, NULL_TREE, - NULL_TREE, false); + if (code->resolved_isym + && code->resolved_isym->id == GFC_ISYM_MOVE_ALLOC) + res = gfc_conv_intrinsic_move_alloc (code); + else + res = gfc_trans_call (code, is_mvbits, NULL_TREE, + NULL_TREE, false); } break; @@ -1373,7 +1413,7 @@ gfc_generate_module_code (gfc_namespace * ns) if (!n->proc_name) continue; - gfc_create_function_decl (n); + gfc_create_function_decl (n, false); gcc_assert (DECL_CONTEXT (n->proc_name->backend_decl) == NULL_TREE); DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl; gfc_module_add_decl (entry, n->proc_name->backend_decl); @@ -1394,3 +1434,56 @@ 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_loc (input_location, 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 fe34f691127..acdd3e30995 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -64,6 +64,13 @@ typedef struct gfc_se pointer assignments. */ unsigned direct_byref:1; + /* If direct_byref is set, do work out the descriptor as in that case but + do still create a new descriptor variable instead of using an + existing one. This is useful for special pointer assignments like + rank remapping where we have to process the descriptor before + assigning to final one. */ + unsigned byref_noassign:1; + /* Ignore absent optional arguments. Used for some intrinsics. */ unsigned ignore_optional:1; @@ -114,8 +121,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; @@ -126,8 +133,9 @@ typedef enum scalarization loop. */ GFC_SS_SCALAR, - /* Like GFC_SS_SCALAR except it evaluates a pointer to the expression. - Used for elemental function parameters. */ + /* Like GFC_SS_SCALAR it evaluates the expression outside the + loop. Is always evaluated as a reference to the temporary. + Used for elemental function arguments. */ GFC_SS_REFERENCE, /* An array section. Scalarization indices will be substituted during @@ -239,6 +247,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; @@ -257,6 +268,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 *); @@ -278,7 +312,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); @@ -298,22 +332,33 @@ 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); /* If the value is not constant, Create a temporary and copy the value. */ tree gfc_evaluate_now (tree, stmtblock_t *); +/* Find the appropriate variant of a math intrinsic. */ +tree gfc_builtin_decl_for_float_kind (enum built_in_function, int); + /* Intrinsic function handling. */ void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *); -/* Does an intrinsic map directly to an external library call. */ +/* Is the intrinsic expanded inline. */ +bool gfc_inline_intrinsic_function_p (gfc_expr *); + +/* Does an intrinsic map directly to an external library call + This is true for array-returning intrinsics, unless + gfc_inline_intrinsic_function_p returns true. */ int gfc_is_intrinsic_libcall (gfc_expr *); +tree gfc_conv_intrinsic_move_alloc (gfc_code *); + /* 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); @@ -383,9 +428,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); @@ -399,10 +441,10 @@ void gfc_set_decl_location (tree, locus *); tree gfc_get_symbol_decl (gfc_symbol *); /* Build a static initializer. */ -tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool); +tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, 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 *); @@ -424,13 +466,15 @@ void gfc_allocate_lang_decl (tree); tree gfc_advance_chain (tree, int); /* Create a decl for a function. */ -void gfc_create_function_decl (gfc_namespace *); +void gfc_create_function_decl (gfc_namespace *, bool); /* Generate the code for a function. */ void gfc_generate_function_code (gfc_namespace *); /* Output a BLOCK DATA program unit. */ 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; @@ -450,7 +494,7 @@ extern GTY(()) tree gfc_static_ctors; void gfc_generate_constructors (void); /* Get the string length of an array constructor. */ -bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor *, tree *); +bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor_base, tree *); /* Generate a runtime error call. */ tree gfc_trans_runtime_error (bool, locus*, const char*, ...); @@ -498,14 +542,16 @@ 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*); +void gfc_process_block_locals (gfc_namespace*, gfc_association_list*); /* 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! */ +/* In f95-lang.c. */ tree pushdecl (tree); tree pushdecl_top_level (tree); void pushlevel (int); @@ -513,12 +559,15 @@ tree poplevel (int, int, int); tree getdecls (void); tree gfc_truthvalue_conversion (tree); tree gfc_builtin_function (tree); + +/* In trans-types.c. */ struct array_descr_info; bool gfc_get_array_descr_info (const_tree, struct array_descr_info *); /* In trans-openmp.c */ bool gfc_omp_privatize_by_reference (const_tree); enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree); +tree gfc_omp_report_decl (tree); tree gfc_omp_clause_default_ctor (tree, tree, tree); tree gfc_omp_clause_copy_ctor (tree, tree, tree); tree gfc_omp_clause_assign_op (tree, tree, tree); @@ -534,6 +583,7 @@ extern GTY(()) tree gfor_fndecl_pause_numeric; extern GTY(()) tree gfor_fndecl_pause_string; extern GTY(()) tree gfor_fndecl_stop_numeric; extern GTY(()) tree gfor_fndecl_stop_string; +extern GTY(()) tree gfor_fndecl_error_stop_numeric; extern GTY(()) tree gfor_fndecl_error_stop_string; extern GTY(()) tree gfor_fndecl_runtime_error; extern GTY(()) tree gfor_fndecl_runtime_error_at; @@ -602,8 +652,6 @@ extern GTY(()) tree gfor_fndecl_convert_char4_to_char1; extern GTY(()) tree gfor_fndecl_size0; extern GTY(()) tree gfor_fndecl_size1; extern GTY(()) tree gfor_fndecl_iargc; -extern GTY(()) tree gfor_fndecl_clz128; -extern GTY(()) tree gfor_fndecl_ctz128; /* Implemented in Fortran. */ extern GTY(()) tree gfor_fndecl_sc_kind; @@ -614,18 +662,24 @@ extern GTY(()) tree gfor_fndecl_sr_kind; /* True if node is an integer constant. */ #define INTEGER_CST_P(node) (TREE_CODE(node) == INTEGER_CST) -/* G95-specific declaration information. */ +/* gfortran-specific declaration information, the _CONT versions denote + arrays with CONTIGUOUS attribute. */ enum gfc_array_kind { GFC_ARRAY_UNKNOWN, GFC_ARRAY_ASSUMED_SHAPE, + GFC_ARRAY_ASSUMED_SHAPE_CONT, GFC_ARRAY_ALLOCATABLE, - GFC_ARRAY_POINTER + GFC_ARRAY_POINTER, + GFC_ARRAY_POINTER_CONT }; /* Array types only. */ -struct GTY(()) lang_type { +/* FIXME: the variable_size annotation here is needed because these types are + variable-sized in some other frontends. Due to gengtype deficiency the GTY + options of such types have to agree across all frontends. */ +struct GTY((variable_size)) lang_type { int rank; enum gfc_array_kind akind; tree lbound[GFC_MAX_DIMENSIONS]; @@ -639,7 +693,7 @@ struct GTY(()) lang_type { tree base_decl[2]; }; -struct GTY(()) lang_decl { +struct GTY((variable_size)) lang_decl { /* Dummy variables. */ tree saved_descriptor; /* Assigned integer nodes. Stringlength is the IO format string's length. @@ -692,14 +746,62 @@ struct GTY(()) lang_decl { #define GFC_TYPE_ARRAY_BASE_DECL(node, internal) \ (TYPE_LANG_SPECIFIC(node)->base_decl[(internal)]) + +/* Create _loc version of build[0-9]. */ + +static inline tree +build1_stat_loc (location_t loc, enum tree_code code, tree type, + tree op MEM_STAT_DECL) +{ + tree t = build1_stat (code, type, op PASS_MEM_STAT); + SET_EXPR_LOCATION (t, loc); + return t; +} +#define build1_loc(l,c,t1,t2) build1_stat_loc (l,c,t1,t2 MEM_STAT_INFO) + +static inline tree +build2_stat_loc (location_t loc, enum tree_code code, tree type, tree arg0, + tree op MEM_STAT_DECL) +{ + tree t = build2_stat (code, type, arg0, op PASS_MEM_STAT); + SET_EXPR_LOCATION (t, loc); + return t; +} +#define build2_loc(l,c,t1,t2,t3) build2_stat_loc (l,c,t1,t2,t3 MEM_STAT_INFO) + +static inline tree +build3_stat_loc (location_t loc, enum tree_code code, tree type, tree arg0, + tree arg1, tree op MEM_STAT_DECL) +{ + tree t = build3_stat (code, type, arg0, arg1, op PASS_MEM_STAT); + SET_EXPR_LOCATION (t, loc); + return t; +} +#define build3_loc(l,c,t1,t2,t3,t4) \ + build3_stat_loc (l,c,t1,t2,t3,t4 MEM_STAT_INFO) + +static inline tree +build4_stat_loc (location_t loc, enum tree_code code, tree type, tree arg0, + tree arg1, tree arg2, tree op MEM_STAT_DECL) +{ + tree t = build4_stat (code, type, arg0, arg1, arg2, op PASS_MEM_STAT); + SET_EXPR_LOCATION (t, loc); + return t; +} +#define build4_loc(l,c,t1,t2,t3,t4,t5) \ + build4_stat_loc (l,c,t1,t2,t3,t4,t5 MEM_STAT_INFO) + + /* Build an expression with void type. */ -#define build1_v(code, arg) fold_build1(code, void_type_node, arg) -#define build2_v(code, arg1, arg2) fold_build2(code, void_type_node, \ - arg1, arg2) -#define build3_v(code, arg1, arg2, arg3) fold_build3(code, void_type_node, \ - arg1, arg2, arg3) -#define build4_v(code, arg1, arg2, arg3, arg4) build4(code, void_type_node, \ - arg1, arg2, arg3, arg4) +#define build1_v(code, arg) \ + fold_build1_loc (input_location, code, void_type_node, arg) +#define build2_v(code, arg1, arg2) \ + fold_build2_loc (input_location, code, void_type_node, arg1, arg2) +#define build3_v(code, arg1, arg2, arg3) \ + fold_build3_loc (input_location, code, void_type_node, arg1, arg2, arg3) +#define build4_v(code, arg1, arg2, arg3, arg4) \ + build4_loc (input_location, code, void_type_node, arg1, arg2, \ + arg3, arg4) /* This group of functions allows a caller to evaluate an expression from the callee's interface. It establishes a mapping between the interface's @@ -773,7 +875,6 @@ void gfc_apply_interface_mapping (gfc_interface_mapping *, /* Standard error messages used in all the trans-*.c files. */ -extern const char gfc_msg_bounds[]; extern const char gfc_msg_fault[]; extern const char gfc_msg_wrong_return[]; |