diff options
| author | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2016-02-10 15:13:54 +0000 |
|---|---|---|
| committer | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2016-02-10 15:13:54 +0000 |
| commit | 8cff878b277f9af6c2827a87581baac5f768e12a (patch) | |
| tree | d4e178503efd243eed24ff3b753cd998370d75d4 /gcc/fortran | |
| parent | 9610b14f8599a9db94822d3f0923b58b2f1177dc (diff) | |
| download | gcc-8cff878b277f9af6c2827a87581baac5f768e12a.tar.gz | |
[./]
2016-02-10 Basile Starynkevitch <basile@starynkevitch.net>
{{merging with some of GCC 6, using
svn merge -r222130:226090 ^/trunk ; UNSTABLE}}
[gcc/]
2016-02-10 Basile Starynkevitch <basile@starynkevitch.net>
{{ merging with trunk 226090 ; UNSTABLE }}
* melt-run.proto.h: include tree-ssa-scopedtables.h
* tree-ssa-dom.c: skip second record_edge_info
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@233272 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/fortran')
50 files changed, 5443 insertions, 1544 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4419b21c90d..47cfa072aaa 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,914 @@ +2015-07-22 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/61831 + PR fortran/66929 + * trans-array.c (gfc_get_proc_ifc_for_expr): Use esym as procedure + symbol if available. + +2015-07-17 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/52846 + * decl.c (gfc_match_end): Pick out declared submodule name from + the composite identifier. + * gfortran.h : Add 'submodule_name' to gfc_use_list structure. + * module.c (gfc_match_submodule): Define submodule_name and add + static 'submodule_name'. + (gfc_match_submodule): Build up submodule filenames, using '@' + as a delimiter. Store the output filename in 'submodule_name'. + Similarly, the submodule identifier is built using '.' as an + identifier. + (gfc_dump_module): If current state is COMP_SUBMODULE, write + to file 'submodule_name', using SUBMODULE_EXTENSION. + (gfc_use_module): Similarly, use the 'submodule_name' field in + the gfc_use_list structure and SUBMODULE_EXTENSION to read the + implicitly used submodule files. + +2015-07-17 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com> + + * trans-intrinsic.c (conv_co_collective): Remove redundant address + operator in the generated code. + +2015-07-17 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/66035 + * trans-expr.c (alloc_scalar_allocatable_for_subcomponent_assignment): + Compute the size to allocate for class and derived type objects + correclty. + (gfc_trans_subcomponent_assign): Only allocate memory for a + component when the object to assign is not an allocatable class + object (the memory is already present for allocatable class objects). + Furthermore use copy_class_to_class for assigning the rhs to the + component (may happen for dummy class objects on the rhs). + +2015-07-17 Mikael Morin <mikael@gcc.gnu.org> + Dominique d'Humieres <dominiq@lps.ens.fr> + + PR fortran/61831 + * trans-array.c (gfc_conv_array_parameter): Guard allocatable + component deallocation code generation with descriptorless + calling convention flag. + * trans-expr.c (gfc_conv_expr_reference): Remove allocatable + component deallocation code generation from revision 212329. + (expr_may_alias_variables): New function. + (gfc_conv_procedure_call): New boolean elemental_proc to factor + check for procedure elemental-ness. Rename boolean f to nodesc_arg + and declare it in the outer scope. Use expr_may_alias_variables, + elemental_proc and nodesc_arg to decide whether generate allocatable + component deallocation code. + (gfc_trans_subarray_assign): Set deep copy flag. + +2015-07-16 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66724 + PR fortran/66724 + * io.c (is_char_type): Call gfc_resolve_expr (). + (match_open_element, match_dt_element, match_inquire_element): Fix + ASYNCHRONOUS case. + +2015-07-15 Andrew MacLeod <amacleod@redhat.com> + + * trans-types.c: Remove multiline #include comment. + +2015-07-14 Steven G. Kargl <kargl@gcc.gnu.org> + + * simplify.c (gfc_simplify_floor): Set precision of temporary to + that of arg. + +2015-07-13 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/64589 + * class.c (find_intrinsic_vtab): Put/Search vtabs for intrinsic + types in the top-level namespace. + +2015-07-12 Aldy Hernandez <aldyh@redhat.com> + + * trans-stmt.c: Fix double word typos. + +2015-07-09 Andrew MacLeod <amacleod@redhat.com> + + * arith.c: Adjust includes for flags.h changes. + * array.c: Likewise. + * check.c: Likewise. + * decl.c: Likewise. + * error.c: Likewise. + * expr.c: Likewise. + * frontend-passes.c: Likewise. + * interface.c: Likewise. + * intrinsic.c: Likewise. + * io.c: Likewise. + * match.c: Likewise. + * openmp.c: Likewise. + * parse.c: Likewise. + * primary.c: Likewise. + * resolve.c: Likewise. + * scanner.c: Likewise. + * simplify.c: Likewise. + * symbol.c: Likewise. + * target-memory.c: Likewise. + +2015-07-07 Andrew MacLeod <amacleod@redhat.com> + + * convert.c: Adjust includes. + * cpp.c: Likewise. + * decl.c: Likewise. + * f95-lang.c: Likewise. + * iresolve.c: Likewise. + * match.c: Likewise. + * module.c: Likewise. + * options.c: Likewise. + * target-memory.c: Likewise. + * trans-array.c: Likewise. + * trans-common.c: Likewise. + * trans-const.c: Likewise. + * trans-decl.c: Likewise. + * trans-expr.c: Likewise. + * trans-intrinsic.c: Likewise. + * trans-io.c: Likewise. + * trans-openmp.c: Likewise. + * trans-stmt.c: Likewise. + * trans-types.c: Likewise. + * trans.c: Likewise. + +2015-07-07 Andre Vehreschild <vehre@gmx.de> + + PR fortran/66578 + * trans-array.c (gfc_conv_expr_descriptor): Ensure array descriptor + is one-based for non-full array refs. Correct the offset when a + rank_remap occurs. + +2015-07-06 Steven G. Kargl <kargl@gcc.gnu.org> + + * io.c (check_char_variable): New function. + (match_open_element, match_close_element, match_file_element, + match_dt_element, match_inquire_element, match_wait_element): Use it. + +2015-07-06 Andre Vehreschild <vehre@gmx.de> + + PR fortran/58586 + * resolve.c (resolve_symbol): Non-private functions in modules + with allocatable or pointer components are marked referenced + now. Furthermore is the default init especially for those + components now done in gfc_conf_procedure_call preventing + duplicate code. + * trans-decl.c (gfc_generate_function_code): Generate a fake + result decl for functions returning an object with allocatable + components and initialize them. + * trans-expr.c (gfc_conv_procedure_call): For value typed trees + use the tree without indirect ref. And for non-decl trees + add a temporary variable to prevent evaluating the tree + multiple times (prevent multiple function evaluations). + * trans.h: Made gfc_trans_structure_assign () protoype + available, which is now needed by trans-decl.c:gfc_generate_ + function_code(), too. + +2015-07-04 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66725 + * io.c (is_char_type): New function to test for BT_CHARACTER + (gfc_match_open, gfc_match_close, match_dt_element): Use it. + +2015-07-02 David Edelsohn <dje.gcc@gmail.com> + + * trans-common.c: Include <map> after system.h. + +2015-07-02 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/52846 + * decl.c (get_proc_name): Make a partially populated interface + symbol to carry the characteristics of a module procedure and + its result. + (variable_decl): Declarations of dummies or results in the + abreviated form of module procedure is an error. + (gfc_match_import): IMPORT is not permitted in the interface + declaration of module procedures. + (match_attr_spec): Submodule variables have implicit save + attribute for F2008 onwards. + (gfc_match_prefix): Add 'module' as the a prefix and set the + module_procedure attribute. + (gfc_match_formal_arglist): For a module procedure keep the + interface formal_arglist from the interface, match new the + formal arguments and then compare the number and names of each. + (gfc_match_procedure): Add case COMP_SUBMODULE. + (gfc_match_function_decl, gfc_match_subroutine_decl): Set the + module_procedure attribute. + (gfc_match_entry, gfc_match_end): Add case COMP_SUBMODULE. If + attr abr_modproc_decl is set, switch the message accordingly + for subroutines and functions. + (gfc_match_submod_proc): New function to match the abbreviated + style of submodule declaration. + * gfortran.h : Add ST_SUBMODULE and ST_END_SUBMODULE. Add the + attribute bits 'used_in_submodule' and 'module_procedure'. Add + the bit field 'abr_modproc_decl' to gfc_symbol. Add prototypes + for 'gfc_copy_dummy_sym', 'gfc_check_dummy_characteristics' and + 'gfc_check_result_characteristics'. + * interface.c : Add the prefix 'gfc_' to the names of functions + 'check_dummy(result)_characteristics' and all their references. + * match.h : Add prototype for 'gfc_match_submod_proc' and + 'gfc_match_submodule'. + (check_sym_interfaces): A module procedure is not an error in + a module procedure statment in a generic interface. + * module.c (gfc_match_submodule): New function. Add handling + for the 'module_procedure' attribute bit. + (gfc_use_module): Make sure that a submodule cannot use itself. + * parse.c (decode_statement): Set attr has_'import_set' for + the interface declaration of module procedures. Handle a match + occurring in 'gfc_match_submod_proc' and a match for + 'submodule'. + (gfc_enclosing_unit): Include the state COMP_SUBMODULE. + (gfc_ascii_statement): Add END SUBMODULE. + (accept_statement): Add ST_SUBMODULE. + (parse_spec): Disallow statement functions in a submodule + specification part. + (parse_contained): Add ST_END_SUBMODULE and COMP_SUBMODULE + twice each. + (get_modproc_result): Copy the result symbol of the interface. + (parse_progunit): Call it. + (set_syms_host_assoc): Make symbols from the ancestor module + and submodules use associated, as required by the standard and + set all private components public. Module procedures 'external' + attribute bit is reset and the 'used_in_submodule' bit is set. + (parse_module): If this is a submodule, use the ancestor module + and submodules. Traverse the namespace, calling + 'set_syms_host_assoc'. Add ST_END_SUBMODULE and COMP_SUBMODULE. + * parse.h : Add COMP_SUBMODULE. + * primary.c (match_variable): Add COMP_SUBMODULE. + * resolve.c (compare_fsyms): New function to compare the dummy + characteristics of a module procedure with its interface. + (resolve_fl_procedure): Compare the procedure, result and dummy + characteristics of a module_procedure with its interface, using + 'compare_fsyms' for the dummy arguments. + * symbol.c (gfc_add_procedure): Suppress the check for existing + procedures in the case of a module procedure. + (gfc_add_explicit_interface): Skip checks that must fail for + module procedures. + (gfc_add_type): Allow a new type to be added to module + procedures, their results or their dummy arguments. + (gfc_copy_dummy_sym): New function to generate new dummy args + and copy the characteristics from the interface. + * trans-decl.c (gfc_sym_mangled_function_id): Module procedures + must always have their names mangled as if they are symbols + coming from a declaration in a module. + (gfc_get_symbol_decl): Add 'used_in_submodule' to the assert. + (gfc_finish_var_decl): Symbols with the 'used_in_submodule' bit + set are set DECL_EXTERNAL as if they were use associated. + +2015-07-02 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/56520 + * match.c (gfc_match_name): Special case unary minus and plus. + +2015-07-02 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66545 + * primary.c (match_sym_complex_part): Do not dereference NULL pointer. + +2015-07-01 Thomas Koenig <tkoenig@gcc.gnu.org> + + * arith.c (gfc_arith_divide): With -Winteger-division, + warn about contant integer division if there is a non-zero + remainder. + * invoke.texi: Document -Winteger-division. + * lang.opt: Add -Winteger-division. + +2015-06-25 Andrew MacLeod <amacleod@redhat.com> + + * f95-lang.c: Remove ipa-ref.h and plugin-api.h from include list. + * trans-decl.c: Likewise. + +2015-06-25 Richard Sandiford <richard.sandiford@arm.com> + + * trans-decl.c (module_hasher): Likewise. + * trans.h (module_decl_hasher): Likewise. + +2015-06-24 Manuel López-Ibáñez <manu@gcc.gnu.org> + + PR fortran/66528 + * error.c (gfc_warning_check): Restore the default output_buffer + before calling diagnostic_action_after_output. + (gfc_error_check): Likewise. + (gfc_diagnostics_init): Add comment. + +2015-06-23 Andre Vehreschild <vehre@gmx.de> + + PR fortran/64674 + * parse.c (parse_associate): Figure the rank and as of a + class array in an associate early. + * primary.c (gfc_match_varspec): Prevent setting the + dimension attribute on the sym for classes. + * resolve.c (resolve_variable): Correct the component + ref's type for associated variables. Add a full array ref + when class array's are associated. + (resolve_assoc_var): Correct the type of the symbol, + when in the associate the expression's rank becomes scalar. + * trans-expr.c (gfc_conv_variable): Indirect ref needed for + allocatable associated objects. + +2015-06-19 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/66549 + * resolve.c (resolve_global_procedure): Don't save and restore + OpenMP state around the call to gfc_resolve. + (gfc_resolve): Save OpenMP state on entry and restore it on return. + +2015-06-17 Andrew MacLeod <amacleod@redhat.com> + + * convert.c: Do not include input.h, line-map.h or is-a.h. + * cpp.c: Likewise. + * decl.c: Likewise. + * f95-lang.c: Likewise. + * gfortran.h: Likewise. + * iresolve.c: Likewise. + * match.c: Likewise. + * module.c: Likewise. + * options.c: Likewise. + * target-memory.c: Likewise. + * trans-array.c: Likewise. + * trans-common.c: Likewise. + * trans-const.c: Likewise. + * trans-decl.c: Likewise. + * trans-expr.c: Likewise. + * trans-intrinsic.c: Likewise. + * trans-io.c: Likewise. + * trans-openmp.c: Likewise. + * trans-stmt.c: Likewise. + * trans-types.c: Likewise. + * trans.c: Likewise. + +2015-06-15 Andre Vehreschild <vehre@gmx.de> + + PR fortran/44672 + PR fortran/45440 + PR fortran/57307 + * gfortran.h: Extend gfc_code.ext.alloc to carry a + flag indicating that the array specification has to be + taken from expr3. + * resolve.c (resolve_allocate_expr): Add F2008 notify + and flag indicating source driven array spec. + (resolve_allocate_deallocate): Check for source driven + array spec, when array to allocate has no explicit + array spec. + * trans-array.c (gfc_array_init_size): Get lower and + upper bound from a tree array descriptor, except when + the source expression is an array-constructor which is + fixed to be one-based. + (retrieve_last_ref): Extracted from gfc_array_allocate(). + (gfc_array_allocate): Enable allocate(array, source= + array_expression) as specified by F2008:C633. + (gfc_conv_expr_descriptor): Add class tree expression + into the saved descriptor for class arrays. + * trans-array.h: Add temporary array descriptor to + gfc_array_allocate (). + * trans-expr.c (gfc_conv_procedure_call): Special handling + for _copy() routine translation, that comes without an + interface. Third and fourth argument are now passed by value. + * trans-stmt.c (gfc_trans_allocate): Get expr3 array + descriptor for temporary arrays to allow allocate(array, + source = array_expression) for array without array + specification. + +2015-06-14 Thomas Koenig <tkoenig@gcc.gnu.org> + + * intrinsic.texi: Change \leq to < in descrition of imaginary + part in argument to log. + +2015-06-11 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/66079 + * trans-expr.c (gfc_conv_procedure_call): Allocatable scalar + function results must be freed and nullified after use. Create + a temporary to hold the result to prevent duplicate calls. + * trans-stmt.c (gfc_trans_allocate): Rename temporary variable + as 'source'. Deallocate allocatable components of non-variable + 'source's. + +2015-06-11 Pierre-Marie de Rodat <derodat@adacore.com> + + * f95-lang.c (gfc_create_decls): Register the main translation unit + through the new debug hook. + +2015-06-08 Andrew MacLeod <amacleod@redhat.com> + + * convert.c : Adjust include files. + * cpp.c : Likewise. + * decl.c : Likewise. + * f95-lang.c : Likewise. + * gfortran.h : Likewise. + * iresolve.c : Likewise. + * match.c : Likewise. + * module.c : Likewise. + * openmp.c : Likewise. + * options.c : Likewise. + * target-memory.c : Likewise. + * trans-array.c : Likewise. + * trans-common.c : Likewise. + * trans-const.c : Likewise. + * trans-decl.c : Likewise. + * trans-expr.c : Likewise. + * trans-intrinsic.c : Likewise. + * trans-io.c : Likewise. + * trans-openmp.c : Likewise. + * trans-stmt.c : Likewise. + * trans-types.c : Likewise. + * trans.c : Likewise. + +2015-06-08 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66245 + * match.c (gfc_match_type_is, gfc_match_class_is): Check if the + return type spec or derived type spec is validate. + +2015-06-06 Thomas Koenig <tkoenig@netcologne.de> + + PR fortran/47659 + * arith.c (eval_intrinsic_op): Set warn flag for + gfc_type_convert_binary if -Wconversion or -Wconversion-extra + are set. + (wprecision_real_real): New function. + (wprecision_int_real): New function. + (gfc_int2int): If -fno-range-check and -Wconversion are specified + and it is a narrowing conversion, warn. + (gfc_int2real): If there is a change in value for the conversion, + warn. + (gfc_int2complex): Likewise. + (gfc_real2int): If there is a fractional part to the real number, + warn with -Wconversion, otherwise warn with -Wconversion-extra. + (gfc_real2real): Emit warning if the constant was changed by + conversion with either -Wconversion or -Wconversion-extra. With + -Wconversion-extra, warn if no warning was issued earlier. + (gfc_real2complex): Likewise. + (gfc_complex2int): For -Wconversion or -Wconversion-extra, if + there was an imaginary part, warn; otherwise, warn for change in + value. Warn with -Wconversion-extra if no other warning was + issued. + (gfc_complex2real): For -Wconversion or -Wconversion-extra, if + there was an imaginary part, warn; otherwise, warn for change in + value. Warn with -Wconversion-extra if no other warning was + issued. + (gfc_complex2complex): For -Wconversion, warn if the value of + either the real or the imaginary part was changed. Warn for + -Wconversion-extra if no prior warning was issued. + * expr.c (gfc_check_assign): Remove check for change in value. + * primary.c (match_real_constant): For -Wconversion-extra, check + against a number in which the last non-zero digit has been + replaced with a zero. If the number compares equal, warn. + * intrinsic.c (gfc_convert_type_warn): Do not warn about constant + conversions. + +2015-06-05 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66347 + * resolve.c (apply_default_init_local): Do not dereference a NULL + pointer. + +2015-06-05 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/66385 + * frontend-passes.c (combine_array_constructor): Return early if + inside a FORALL loop. + +2015-06-05 Aldy Hernandez <aldyh@redhat.com> + + * f95-lang.c (gfc_write_global_declarations): Remove. + (LANG_HOOKS_WRITE_GLOBALS): Remove. + (gfc_write_global_declarations): Move code from here to... + (gfc_be_parse_file): ...here. + Call global_decl_processing. + * trans-decl.c (gfc_emit_parameter_debug_info): Rename global_decl + to early_global_decl. + +2015-06-05 Russell Whitesides <russelldub@gmail.com> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/40958 + PR fortran/60780 + PR fortran/66377 + * module.c (load_equiv): Add check for loading duplicate EQUIVALENCEs + from different modules. Eliminate the pruning of unused + equivalence-objects + +2015-06-04 Thomas Koenig <tkoenig@netcologne.de> + + PR fortran/58749 + * iresolve.c (gfc_resolve_adjustl): If string has a charlen, + copy it to the function. + (gfc_resolve_adjustr): Likewise. + +2015-06-04 Andrew MacLeod <amacleod@redhat.com> + + * convert.c: Adjust includes for restructured coretypes.h. + * cpp.c: Likewise. + * decl.c: Likewise. + * f95-lang.c: Likewise. + * iresolve.c: Likewise. + * match.c: Likewise. + * module.c: Likewise. + * options.c: Likewise. + * target-memory.c: Likewise. + * trans-array.c: Likewise. + * trans-common.c: Likewise. + * trans-const.c: Likewise. + * trans-decl.c: Likewise. + * trans-expr.c: Likewise. + * trans-intrinsic.c: Likewise. + * trans-io.c: Likewise. + * trans-openmp.c: Likewise. + * trans-stmt.c: Likewise. + * trans-types.c: Likewise. + * trans.c: Likewise. + +2015-06-02 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66380 + * simplify.c (gfc_simplify_reshape): Convert assert into returning + NULL, which triggers an error condition. + +2015-05-27 Andre Vehreschild <vehre@gmx.de> + + PR fortran/65548 + * trans-stmt.c (gfc_trans_allocate): Add missing location + information for e3rhs. + +2015-05-26 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/66082 + * trans-array.c (gfc_conv_array_parameter): Ensure that all + non-variable arrays with allocatable components have the + components deallocated after the procedure call. + +2015-05-24 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/66257 + * resolve.c (resolve_actual_arglist): Don't throw an error + if the argument with procedure pointer component is not a variable. + +2015-05-24 Manuel López-Ibáñez <manu@gcc.gnu.org> + + PR fortran/44054 + * gfortran.h (struct gfc_error_buf): Rename as + gfc_error_buffer. Move closer to push, pop and free + methods. Reimplement using an output_buffer. + * error.c (errors, warnings, warning_buffer, cur_error_buffer): + Delete everywhere in this file. + (error_char): Delete all contents. + (gfc_increment_error_count): Delete. + (gfc_error_now): Update comment. Set error_buffer.flag. + (gfc_warning_check): Do not handle warning_buffer. + (gfc_error_1): Delete. + (gfc_error_now_1): Delete. + (gfc_error_check): Simplify. + (gfc_move_error_buffer_from_to): Renamed from + gfc_move_output_buffer_from_to. + (gfc_push_error): Handle only gfc_error_buffer. + (gfc_pop_error): Likewise. + (gfc_free_error): Likewise. + (gfc_get_errors): Remove warnings and errors. + (gfc_diagnostics_init): Use static error_buffer. + (gfc_error_1,gfc_error_now_1): Delete declarations. + * symbol.c, decl.c, trans-common.c, data.c, expr.c, expr.c, + frontend-passes.c, resolve.c, match.c, parse.c: Replace + gfc_error_1 with gfc_error and gfc_error_now_1 with gfc_error_1 + everywhere. + * f95-lang.c (gfc_be_parse_file): Do not update errorcount and + warningcount here. + * primary.c (match_complex_constant): Replace gfc_error_buf and + output_buffer with gfc_error_buffer. + +2015-05-22 Jim Wilson <jim.wilson@linaro.org> + + * Make-lang.in (check_gfortran_parallelize): Update comment. + +2015-05-21 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/66176 + * frontend-passes.c (check_conjg_variable): New function. + (inline_matmul_assign): Use it to keep track of conjugated + variables. + +2015-05-20 Andre Vehreschild <vehre@gmx.de> + + PR fortran/65548 + * trans-stmt.c (gfc_trans_allocate): Always retrieve the + descriptor or a reference to a source= expression for + arrays and non-arrays, respectively. Use a temporary + symbol and gfc_trans_assignment for all source= + assignments to allocated objects besides for class and + derived types. + +2015-05-19 Jakub Jelinek <jakub@redhat.com> + + PR middle-end/66199 + * trans-openmp.c (gfc_trans_omp_teams): Set OMP_TEAMS_COMBINED for + combined constructs. + (gfc_trans_omp_target): Make sure BIND_EXPR has non-NULL + BIND_EXPR_BLOCK. + +2015-05-19 David Malcolm <dmalcolm@redhat.com> + + * cpp.c (maybe_print_line): Strengthen local "map" from + const line_map * to const line_map_ordinary *. + (cb_file_change): Likewise for param "map" and local "from". + (cb_line_change): Likewise for local "map". + +2015-05-19 Mikhail Maltsev <maltsevm@gmail.com> + + * interface.c (compare_actual_formal): Use std::swap instead of + explicit swaps. + * trans-array.c (gfc_trans_scalarized_loop_end): Likewise. + * trans-intrinsic.c (walk_inline_intrinsic_transpose): Likewise. + +2015-05-18 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66106 + * interface.c(gfc_match_end_interface): Enforce F2008 C1202 (R1201). + * match.c(gfc_op2string): Return 'none' for INTRINSIC_NONE. + +2015-05-18 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66057 + * decl.c(gfc_match_generic): Detected a malformed GENERIC statement. + +2015-05-18 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66043 + * gfortran.dg/storage_size_6.f90: New tests. + +2015-05-18 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66043 + * gfortran.dg/storage_size_6.f90: New tests. + +2015-05-18 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66044 + * decl.c(gfc_match_entry): Change a gfc_internal_error() into + a gfc_error() + +2015-05-18 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66043 + * gfortran.dg/storage_size_6.f90: New tests. + +2015-05-18 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66040 + * parse.c(verify_st_order): Replace a gfc_internal_error with your + generic gfc_error. + +2015-05-18 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/66039 + * io.c (match_filepos): Check for incomplete/mangled REWIND, FLUSH, + BACKSPACE, and ENDFILE statements + +2015-05-18 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/64925 + * symbol.c(check_conflict): Check for a conflict between a dummy + argument and an internal procedure name. + +2015-05-16 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/65903 + * io.c (format_lex): Change to NONSTRING when checking for + possible doubled quote. + * scanner.c (gfc_next_char_literal): Revert change from 64506 + and add a check for quotes and return. + +2015-05-16 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/66113 + * expr.c (is_parent_of_current_ns): New function. + (check_restricted): Use it. + +2015-05-16 Manuel López-Ibáñez <manu@gcc.gnu.org> + + PR fortran/44054 + + Replace all calls to gfc_notify_std_1 with gfc_notify_std and + gfc_warning_1 with gfc_warning. + * decl.c (gfc_verify_c_interop_param): Here. + * resolve.c (resolve_branch): Here. + (resolve_fl_derived): Here. + * dependency.c (gfc_check_argument_var_dependency): + * scanner.c (preprocessor_line): Use gfc_warning_now_at. Fix line + counter and locations before and after warning. + * gfortran.h (gfc_warning_1, gfc_warning_now_1, gfc_notify_std_1): + Delete. + (gfc_warning_now_at): Declare. + * error.c (gfc_warning_1): Delete. + (gfc_notify_std_1): Delete. + (gfc_warning_now_1): Delete. + (gfc_format_decoder): Handle two locations. + (gfc_diagnostic_build_prefix): Rename as + gfc_diagnostic_build_kind_prefix. + (gfc_diagnostic_build_locus_prefix): Take an expanded_location + instead of diagnostic_info. + (gfc_diagnostic_build_locus_prefix): Add overload that takes two + expanded_location. + (gfc_diagnostic_starter): Handle two locations. + (gfc_warning_now_at): New. + (gfc_diagnostics_init): Initialize caret_chars array. + (gfc_diagnostics_finish): Reset caret_chars array to default. + +2015-05-16 Mikael Morin <mikael@gcc.gnu.org> + Paul Thomas <pault@gcc.gnu.org> + + PR fortran/65792 + * trans-expr.c (gfc_trans_subcomponent_assign): Always assign + the expression component to the destination. In addition, if + the component has allocatable components, copy them and + deallocate those of the expression, if it is not a variable. + The expression is fixed if not a variable to prevent multiple + evaluations. + +2015-05-12 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/66111 + * frontend-passes.c (has_dimen_vector_ref): New function. + (inline_matmul_assign): Use it to return early in case + of unhandled vector subscripts. + +2015-05-12 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/66041 + PR fortran/37131 + * gfortran.h (gfc_array_spec): Add field resolved. + * array.c (gfc_resolve_array_spec): Resolve array spec + only once. + +2015-05-11 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/66100 + * simplify.c (simplify_bound): Fix assert to accept subobject arrays. + +2015-05-10 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/66041 + * frontend-passes.c (scalarized_expr): Set correct dimension and + shape for the expression to be passed to lbound. Remove trailing + references after array refrence. + (inline_matmul_assign): Remove gfc_copy_expr from calls + to scalarized_expr(). + +2015-05-10 Mikael Morin <mikael@gcc.gnu.org> + + * simplify.c (simplify_bound_dim): Don't check for emptyness + in the case of cobound simplification. Factor lower/upper + bound differenciation before the actual simplification. + (simplify_bound): Remove assumed shape specific simplification. + Don't give up early for the lbound of an assumed shape. + +2015-05-09 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/65894 + * trans-array.h (gfc_scalar_elemental_arg_saved_as_reference): + New prototype. + * trans-array.c (gfc_scalar_elemental_arg_saved_as_reference): + New function. + (gfc_add_loop_ss_code): Use gfc_scalar_elemental_arg_saved_as_reference + as conditional. + (gfc_walk_elemental_function_args): Set the dummy_arg field. + * trans.h (gfc_ss_info): New subfield dummy_arg. + * trans-expr.c (gfc_conv_procedure_call): Revert the change + of revision 222361. + (gfc_conv_expr): Use gfc_scalar_elemental_arg_saved_as_reference + as conditional. + +2015-05-08 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.c (gfc_walk_elemental_function_args): + Don't skip the advance to the next dummy argument when skipping + absent optional args. + +2015-05-05 David Malcolm <dmalcolm@redhat.com> + + * expr.c (check_inquiry): Fix indentation so that it reflects the + block structure. + * interface.c (compare_parameter): Likewise. + * parse.c (parse_oacc_structured_block): Likewise. + * target-memory.c (expr_to_char): Likewise. + * trans-types.c (gfc_init_kinds): Likewise. + +2015-05-02 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/65976 + * invoke.texi: Remove 'no-' in '-fno-fixed-form' + +2015-05-01 Mikael Morin <mikael@gcc.gnu.org> + + * simplify.c (simplify_bound_dim): Tighten the check for array fullness + by also checking for absence of subreference. + (simplify_bound): Don't skip simplification if the array + has subreferences. + (simplify_cobound): Same. + +2015-04-30 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/37131 + * simplify.c (simplify_bound): Get constant lower bounds of one + from array spec for assumed and explicit shape shape arrays if + the lower bounds are indeed one. + +2015-04-30 David Malcolm <dmalcolm@redhat.com> + + * options.c (gfc_init_options): Remove spurious second + semicolon. + * trans-stmt.c (gfc_trans_allocate): Likewise. + +2015-04-28 Andre Vehreschild <vehre@gmx.de> + + * interface.c (gfc_compare_types): Check for unlimited + polymorphism flag in the correct position indepent of the _data + component being present or not. This prevents a segfault, when + the _data component is not present. + * symbol.c (gfc_type_compatible): Same. + +2015-04-27 Jim Wilson <jim.wilson@linaro.org> + + * Make-lang.in (fortran.mostlyclean): Remove gfortran and + gfortran-cross. + +2015-04-27 Andre Vehreschild <vehre@gmx.de> + + PR fortran/59678 + PR fortran/65841 + * trans-array.c (duplicate_allocatable): Fixed deep copy of + allocatable components, which are liable for copy only, when + they are allocated. + (gfc_duplicate_allocatable): Add deep-copy code into if + component allocated block. Needed interface change for that. + (gfc_copy_allocatable_data): Supplying NULL_TREE for code to + add into if-block for checking whether a component was + allocated. + (gfc_duplicate_allocatable_nocopy): Likewise. + (structure_alloc_comps): Likewise. + * trans-array.h: Likewise. + * trans-expr.c (gfc_trans_alloc_subarray_assign): Likewise. + * trans-openmp.c (gfc_walk_alloc_comps): Likewise. + +2015-04-23 Andre Vehreschild <vehre@gmx.de> + + PR fortran/60322 + * expr.c (gfc_lval_expr_from_sym): Code to select the regular + or class array added. + * gfortran.h: Add IS_CLASS_ARRAY macro. + * trans-array.c (gfc_add_loop_ss_code): Treat class objects + to be referenced always. + (build_class_array_ref): Adapt retrieval of array descriptor. + (build_array_ref): Likewise. + (gfc_conv_array_ref): Hand the vptr or the descriptor to + build_array_ref depending whether the sym is class or not. + (gfc_trans_array_cobounds): Select correct gfc_array_spec for + regular and class arrays. + (gfc_trans_array_bounds): Likewise. + (gfc_trans_dummy_array_bias): Likewise. + (gfc_get_dataptr_offset): Correcting call of build_array_ref. + (gfc_conv_expr_descriptor): Set the array's offset to -1 when + lbound in inner most dim is 1 and symbol non-pointer/assoc. + * trans-decl.c (gfc_build_qualified_array): Select correct + gfc_array_spec for regular and class arrays. + (gfc_build_dummy_array_decl): Likewise. + (gfc_get_symbol_decl): Get a dummy array for class arrays. + (gfc_trans_deferred_vars): Tell conv_expr that the descriptor + is desired. + * trans-expr.c (gfc_class_vptr_get): Get the class descriptor + from the correct location for class arrays. + (gfc_class_len_get): Likewise. + (gfc_conv_intrinsic_to_class): Add handling of _len component. + (gfc_conv_class_to_class): Prevent access to unset array data + when the array is an optional argument. Add handling of _len + component. + (gfc_copy_class_to_class): Check that _def_init is non-NULL + when used in _vptr->copy() + (gfc_trans_class_init_assign): Ensure that the rank of + _def_init is zero. + (gfc_conv_component_ref): Get the _vptr along with _data refs. + (gfc_conv_variable): Make sure the temp array descriptor is + returned for class arrays, too, and that class arrays are + dereferenced correctly. + (gfc_conv_procedure_call): For polymorphic type initialization + the initializer has to be a pointer to _def_init stored in a + dummy variable, which then needs to be used by value. + * trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Use the + temporary array descriptor for class arrays, too. + (gfc_conv_intrinsic_storage_size): Likewise. + (gfc_conv_intrinsic_loc): Add ref to _data for BT_CLASS + expressions. + * trans-stmt.c (trans_associate_var): Use a temporary array for + the associate variable of class arrays, too, making the array + one-based (lbound == 1). + * trans-types.c (gfc_is_nodesc_array): Use the correct + array data. + * trans.c (gfc_build_array_ref): Use the dummy array descriptor + when present. + * trans.h: Add class_vptr to gfc_se for storing a class ref's + vptr. + +2015-04-22 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/65429 + * decl.c (add_init_expr_to_sym): Set the length type parameter. + 2015-04-10 Tobias Burnus <burnus@net-b.de> * trans-stmt.c (gfc_trans_lock_unlock): Implement -fcoarray=lib diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in index ed74a5ced0a..807c29e6bf0 100644 --- a/gcc/fortran/Make-lang.in +++ b/gcc/fortran/Make-lang.in @@ -167,7 +167,7 @@ check-f95-subtargets : check-gfortran-subtargets check-fortran-subtargets : check-gfortran-subtargets lang_checks += check-gfortran lang_checks_parallelized += check-gfortran -# For description see comment above check_gcc_parallelize in gcc/Makefile.in. +# For description see the check_$lang_parallelize comment in gcc/Makefile.in. check_gfortran_parallelize = 10000 # GFORTRAN documentation. @@ -275,7 +275,7 @@ fortran.uninstall: # We just have to delete files specific to us. fortran.mostlyclean: - -rm -f f951$(exeext) + -rm -f gfortran$(exeext) gfortran-cross$(exeext) f951$(exeext) -rm -f fortran/*.o fortran.clean: diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index b9c25c10e89..e4da3b927fc 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -26,7 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "flags.h" +#include "options.h" #include "gfortran.h" #include "arith.h" #include "target-memory.h" @@ -731,8 +731,28 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) break; } - mpz_tdiv_q (result->value.integer, op1->value.integer, - op2->value.integer); + if (warn_integer_division) + { + mpz_t r; + mpz_init (r); + mpz_tdiv_qr (result->value.integer, r, op1->value.integer, + op2->value.integer); + + if (mpz_cmp_si (r, 0) != 0) + { + char *p; + p = mpz_get_str (NULL, 10, result->value.integer); + gfc_warning_now (OPT_Winteger_division, "Integer division " + "truncated to constant %qs at %L", p, + &op1->where); + free (p); + } + mpz_clear (r); + } + else + mpz_tdiv_q (result->value.integer, op1->value.integer, + op2->value.integer); + break; case BT_REAL: @@ -1521,7 +1541,7 @@ eval_intrinsic (gfc_intrinsic_op op, temp.value.op.op1 = op1; temp.value.op.op2 = op2; - gfc_type_convert_binary (&temp, 0); + gfc_type_convert_binary (&temp, warn_conversion || warn_conversion_extra); if (op == INTRINSIC_EQ || op == INTRINSIC_NE || op == INTRINSIC_GE || op == INTRINSIC_GT @@ -1949,6 +1969,42 @@ arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where) NaN, etc. */ } +/* Returns true if significant bits were lost when converting real + constant r from from_kind to to_kind. */ + +static bool +wprecision_real_real (mpfr_t r, int from_kind, int to_kind) +{ + mpfr_t rv, diff; + bool ret; + + gfc_set_model_kind (to_kind); + mpfr_init (rv); + gfc_set_model_kind (from_kind); + mpfr_init (diff); + + mpfr_set (rv, r, GFC_RND_MODE); + mpfr_sub (diff, rv, r, GFC_RND_MODE); + + ret = ! mpfr_zero_p (diff); + mpfr_clear (rv); + mpfr_clear (diff); + return ret; +} + +/* Return true if conversion from an integer to a real loses precision. */ + +static bool +wprecision_int_real (mpz_t n, mpfr_t r) +{ + mpz_t i; + mpz_init (i); + mpfr_get_z (i, r, GFC_RND_MODE); + mpz_sub (i, i, n); + return mpz_cmp_si (i, 0) != 0; + mpz_clear (i); + +} /* Convert integers to integers. */ @@ -1985,8 +2041,12 @@ gfc_int2int (gfc_expr *src, int kind) k = gfc_validate_kind (BT_INTEGER, kind, false); gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); - } + if (warn_conversion && kind < src->ts.kind) + gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L", + gfc_typename (&src->ts), gfc_typename (&result->ts), + &src->where); + } return result; } @@ -2010,6 +2070,14 @@ gfc_int2real (gfc_expr *src, int kind) return NULL; } + if (warn_conversion + && wprecision_int_real (src->value.integer, result->value.real)) + gfc_warning_now (OPT_Wconversion, "Change of value in conversion " + "from %qs to %qs at %L", + gfc_typename (&src->ts), + gfc_typename (&result->ts), + &src->where); + return result; } @@ -2034,6 +2102,15 @@ gfc_int2complex (gfc_expr *src, int kind) return NULL; } + if (warn_conversion + && wprecision_int_real (src->value.integer, + mpc_realref (result->value.complex))) + gfc_warning_now (OPT_Wconversion, "Change of value in conversion " + "from %qs to %qs at %L", + gfc_typename (&src->ts), + gfc_typename (&result->ts), + &src->where); + return result; } @@ -2045,6 +2122,7 @@ gfc_real2int (gfc_expr *src, int kind) { gfc_expr *result; arith rc; + bool did_warn = false; result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); @@ -2057,6 +2135,28 @@ gfc_real2int (gfc_expr *src, int kind) return NULL; } + /* If there was a fractional part, warn about this. */ + + if (warn_conversion) + { + mpfr_t f; + mpfr_init (f); + mpfr_frac (f, src->value.real, GFC_RND_MODE); + if (mpfr_cmp_si (f, 0) != 0) + { + gfc_warning_now (OPT_Wconversion, "Change of value in conversion " + "from %qs to %qs at %L", gfc_typename (&src->ts), + gfc_typename (&result->ts), &src->where); + did_warn = true; + } + } + if (!did_warn && warn_conversion_extra) + { + gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " + "at %L", gfc_typename (&src->ts), + gfc_typename (&result->ts), &src->where); + } + return result; } @@ -2068,6 +2168,7 @@ gfc_real2real (gfc_expr *src, int kind) { gfc_expr *result; arith rc; + bool did_warn = false; result = gfc_get_constant_expr (BT_REAL, kind, &src->where); @@ -2088,6 +2189,33 @@ gfc_real2real (gfc_expr *src, int kind) return NULL; } + /* As a special bonus, don't warn about REAL values which are not changed by + the conversion if -Wconversion is specified and -Wconversion-extra is + not. */ + + if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind) + { + int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; + + /* Calculate the difference between the constant and the rounded + value and check it against zero. */ + + if (wprecision_real_real (src->value.real, src->ts.kind, kind)) + { + gfc_warning_now (w, "Change of value in conversion from " + "%qs to %qs at %L", + gfc_typename (&src->ts), gfc_typename (&result->ts), + &src->where); + /* Make sure the conversion warning is not emitted again. */ + did_warn = true; + } + } + + if (!did_warn && warn_conversion_extra) + gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " + "at %L", gfc_typename(&src->ts), + gfc_typename(&result->ts), &src->where); + return result; } @@ -2099,6 +2227,7 @@ gfc_real2complex (gfc_expr *src, int kind) { gfc_expr *result; arith rc; + bool did_warn = false; result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); @@ -2119,6 +2248,26 @@ gfc_real2complex (gfc_expr *src, int kind) return NULL; } + if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind) + { + int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; + + if (wprecision_real_real (src->value.real, src->ts.kind, kind)) + { + gfc_warning_now (w, "Change of value in conversion from " + "%qs to %qs at %L", + gfc_typename (&src->ts), gfc_typename (&result->ts), + &src->where); + /* Make sure the conversion warning is not emitted again. */ + did_warn = true; + } + } + + if (!did_warn && warn_conversion_extra) + gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " + "at %L", gfc_typename(&src->ts), + gfc_typename(&result->ts), &src->where); + return result; } @@ -2130,6 +2279,7 @@ gfc_complex2int (gfc_expr *src, int kind) { gfc_expr *result; arith rc; + bool did_warn = false; result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); @@ -2143,6 +2293,43 @@ gfc_complex2int (gfc_expr *src, int kind) return NULL; } + if (warn_conversion || warn_conversion_extra) + { + int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; + + /* See if we discarded an imaginary part. */ + if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0) + { + gfc_warning_now (w, "Non-zero imaginary part discarded " + "in conversion from %qs to %qs at %L", + gfc_typename(&src->ts), gfc_typename (&result->ts), + &src->where); + did_warn = true; + } + + else { + mpfr_t f; + + mpfr_init (f); + mpfr_frac (f, src->value.real, GFC_RND_MODE); + if (mpfr_cmp_si (f, 0) != 0) + { + gfc_warning_now (w, "Change of value in conversion from " + "%qs to %qs at %L", gfc_typename (&src->ts), + gfc_typename (&result->ts), &src->where); + did_warn = true; + } + mpfr_clear (f); + } + + if (!did_warn && warn_conversion_extra) + { + gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " + "at %L", gfc_typename (&src->ts), + gfc_typename (&result->ts), &src->where); + } + } + return result; } @@ -2154,6 +2341,7 @@ gfc_complex2real (gfc_expr *src, int kind) { gfc_expr *result; arith rc; + bool did_warn = false; result = gfc_get_constant_expr (BT_REAL, kind, &src->where); @@ -2174,6 +2362,41 @@ gfc_complex2real (gfc_expr *src, int kind) return NULL; } + if (warn_conversion || warn_conversion_extra) + { + int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; + + /* See if we discarded an imaginary part. */ + if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0) + { + gfc_warning_now (w, "Non-zero imaginary part discarded " + "in conversion from %qs to %qs at %L", + gfc_typename(&src->ts), gfc_typename (&result->ts), + &src->where); + did_warn = true; + } + + /* Calculate the difference between the real constant and the rounded + value and check it against zero. */ + + if (kind > src->ts.kind + && wprecision_real_real (mpc_realref (src->value.complex), + src->ts.kind, kind)) + { + gfc_warning_now (w, "Change of value in conversion from " + "%qs to %qs at %L", + gfc_typename (&src->ts), gfc_typename (&result->ts), + &src->where); + /* Make sure the conversion warning is not emitted again. */ + did_warn = true; + } + } + + if (!did_warn && warn_conversion_extra) + gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L", + gfc_typename(&src->ts), gfc_typename (&result->ts), + &src->where); + return result; } @@ -2185,6 +2408,7 @@ gfc_complex2complex (gfc_expr *src, int kind) { gfc_expr *result; arith rc; + bool did_warn = false; result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); @@ -2220,6 +2444,26 @@ gfc_complex2complex (gfc_expr *src, int kind) return NULL; } + if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind + && (wprecision_real_real (mpc_realref (src->value.complex), + src->ts.kind, kind) + || wprecision_real_real (mpc_imagref (src->value.complex), + src->ts.kind, kind))) + { + int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; + + gfc_warning_now (w, "Change of value in conversion from " + " %qs to %qs at %L", + gfc_typename (&src->ts), gfc_typename (&result->ts), + &src->where); + did_warn = true; + } + + if (!did_warn && warn_conversion_extra && src->ts.kind != kind) + gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " + "at %L", gfc_typename(&src->ts), + gfc_typename (&result->ts), &src->where); + return result; } diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 64d0abf8fa4..276737b4121 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -21,6 +21,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" +#include "options.h" #include "flags.h" #include "gfortran.h" #include "match.h" @@ -338,6 +339,9 @@ gfc_resolve_array_spec (gfc_array_spec *as, int check_constant) if (as == NULL) return true; + if (as->resolved) + return true; + for (i = 0; i < as->rank + as->corank; i++) { e = as->lower[i]; @@ -364,6 +368,8 @@ gfc_resolve_array_spec (gfc_array_spec *as, int check_constant) } } + as->resolved = true; + return true; } diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index cdb5ff1cba6..6548a017f44 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -28,7 +28,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "flags.h" +#include "options.h" #include "gfortran.h" #include "intrinsic.h" #include "constructor.h" @@ -1031,8 +1031,8 @@ gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no, if (atom->ts.type != value->ts.type) { - gfc_error_1 ("'%s' argument of '%s' intrinsic at %L shall have the same " - "type as '%s' at %L", gfc_current_intrinsic_arg[val_no]->name, + gfc_error ("%qs argument of %qs intrinsic at %L shall have the same " + "type as %qs at %L", gfc_current_intrinsic_arg[val_no]->name, gfc_current_intrinsic, &value->where, gfc_current_intrinsic_arg[atom_no]->name, &atom->where); return false; @@ -1575,7 +1575,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, if (!gfc_compare_types (&a->ts, &sym->result->ts)) { - gfc_error_1 ("A argument at %L has type %s but the function passed as " + gfc_error ("A argument at %L has type %s but the function passed as " "OPERATOR at %L returns %s", &a->where, gfc_typename (&a->ts), &op->where, gfc_typename (&sym->result->ts)); @@ -1655,16 +1655,16 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, && ((formal_size1 && actual_size != formal_size1) || (formal_size2 && actual_size != formal_size2))) { - gfc_error_1 ("The character length of the A argument at %L and of the " - "arguments of the OPERATOR at %L shall be the same", + gfc_error ("The character length of the A argument at %L and of the " + "arguments of the OPERATOR at %L shall be the same", &a->where, &op->where); return false; } if (actual_size && result_size && actual_size != result_size) { - gfc_error_1 ("The character length of the A argument at %L and of the " - "function result of the OPERATOR at %L shall be the same", - &a->where, &op->where); + gfc_error ("The character length of the A argument at %L and of the " + "function result of the OPERATOR at %L shall be the same", + &a->where, &op->where); return false; } } @@ -1680,10 +1680,10 @@ gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL && a->ts.type != BT_CHARACTER) { - gfc_error_1 ("'%s' argument of '%s' intrinsic at %L shall be of type " - "integer, real or character", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &a->where); + gfc_error ("%qs argument of %qs intrinsic at %L shall be of type " + "integer, real or character", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &a->where); return false; } return check_co_collective (a, result_image, stat, errmsg, false); @@ -1956,7 +1956,7 @@ gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift) if (i->is_boz && j->is_boz) { - gfc_error_1 ("'I' at %L and 'J' at %L cannot both be BOZ literal " + gfc_error ("%<I%> at %L and %<J%>' at %L cannot both be BOZ literal " "constants", &i->where, &j->where); return false; } @@ -2472,9 +2472,9 @@ gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size) if (i2 > i3) { - gfc_error_1 ("The absolute value of SHIFT at %L must be less " - "than or equal to SIZE at %L", &shift->where, - &size->where); + gfc_error ("The absolute value of SHIFT at %L must be less " + "than or equal to SIZE at %L", &shift->where, + &size->where); return false; } } @@ -5527,6 +5527,36 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) return true; } +bool +gfc_check_fe_runtime_error (gfc_actual_arglist *a) +{ + gfc_expr *e; + int len, i; + int num_percent, nargs; + + e = a->expr; + if (e->expr_type != EXPR_CONSTANT) + return true; + + len = e->value.character.length; + if (e->value.character.string[len-1] != '\0') + gfc_internal_error ("fe_runtime_error string must be null terminated"); + + num_percent = 0; + for (i=0; i<len-1; i++) + if (e->value.character.string[i] == '%') + num_percent ++; + + nargs = 0; + for (; a; a = a->next) + nargs ++; + + if (nargs -1 != num_percent) + gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)", + nargs, num_percent++); + + return true; +} bool gfc_check_second_sub (gfc_expr *time) @@ -6213,6 +6243,15 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) bool gfc_check_storage_size (gfc_expr *a, gfc_expr *kind) { + + if (a->expr_type == EXPR_NULL) + { + gfc_error ("Intrinsic function NULL at %L cannot be an actual " + "argument to STORAGE_SIZE, because it returns a " + "disassociated pointer", &a->where); + return false; + } + if (a->ts.type == BT_ASSUMED) { gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)", diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 799039999db..218973dc048 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -2511,10 +2511,8 @@ find_intrinsic_vtab (gfc_typespec *ts) sprintf (name, "__vtab_%s", tname); - /* Look for the vtab symbol in various namespaces. */ - gfc_find_symbol (name, gfc_current_ns, 0, &vtab); - if (vtab == NULL) - gfc_find_symbol (name, ns, 0, &vtab); + /* Look for the vtab symbol in the top-level namespace only. */ + gfc_find_symbol (name, ns, 0, &vtab); if (vtab == NULL) { diff --git a/gcc/fortran/convert.c b/gcc/fortran/convert.c index 261083dcf6e..21fc36fc747 100644 --- a/gcc/fortran/convert.c +++ b/gcc/fortran/convert.c @@ -25,17 +25,9 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "options.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" +#include "options.h" #include "fold-const.h" #include "convert.h" diff --git a/gcc/fortran/cpp.c b/gcc/fortran/cpp.c index e239f21b565..daffc2069bf 100644 --- a/gcc/fortran/cpp.c +++ b/gcc/fortran/cpp.c @@ -20,15 +20,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tm.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" #include "version.h" #include "flags.h" @@ -147,7 +139,7 @@ static void scan_translation_unit_trad (cpp_reader *); /* Callback routines for the parser. Most of these are active only in specific modes. */ -static void cb_file_change (cpp_reader *, const struct line_map *); +static void cb_file_change (cpp_reader *, const line_map_ordinary *); static void cb_line_change (cpp_reader *, const cpp_token *, int); static void cb_define (cpp_reader *, source_location, cpp_hashnode *); static void cb_undef (cpp_reader *, source_location, cpp_hashnode *); @@ -807,7 +799,8 @@ scan_translation_unit_trad (cpp_reader *pfile) static void maybe_print_line (source_location src_loc) { - const struct line_map *map = linemap_lookup (line_table, src_loc); + const line_map_ordinary *map + = linemap_check_ordinary (linemap_lookup (line_table, src_loc)); int src_line = SOURCE_LINE (map, src_loc); /* End the previous line of text. */ @@ -874,7 +867,7 @@ print_line (source_location src_loc, const char *special_flags) } static void -cb_file_change (cpp_reader * ARG_UNUSED (pfile), const struct line_map *map) +cb_file_change (cpp_reader * ARG_UNUSED (pfile), const line_map_ordinary *map) { const char *flags = ""; @@ -896,7 +889,7 @@ cb_file_change (cpp_reader * ARG_UNUSED (pfile), const struct line_map *map) /* Bring current file to correct line when entering a new file. */ if (map->reason == LC_ENTER) { - const struct line_map *from = INCLUDED_FROM (line_table, map); + const line_map_ordinary *from = INCLUDED_FROM (line_table, map); maybe_print_line (LAST_SOURCE_LINE_LOCATION (from)); } if (map->reason == LC_ENTER) @@ -930,7 +923,8 @@ cb_line_change (cpp_reader *pfile, const cpp_token *token, ought to care. Some things do care; the fault lies with them. */ if (!CPP_OPTION (pfile, traditional)) { - const struct line_map *map = linemap_lookup (line_table, src_loc); + const line_map_ordinary *map + = linemap_check_ordinary (linemap_lookup (line_table, src_loc)); int spaces = SOURCE_COLUMN (map, src_loc) - 2; print.printed = 1; diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c index 4fd84e4b415..ef9101b8d55 100644 --- a/gcc/fortran/data.c +++ b/gcc/fortran/data.c @@ -253,9 +253,9 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index, if (init && expr->expr_type != EXPR_ARRAY) { - gfc_error_1 ("'%s' at %L already is initialized at %L", - lvalue->symtree->n.sym->name, &lvalue->where, - &init->where); + gfc_error ("%qs at %L already is initialized at %L", + lvalue->symtree->n.sym->name, &lvalue->where, + &init->where); goto abort; } diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 037a8cc47c3..ebc88eaa5dd 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -24,17 +24,9 @@ along with GCC; see the file COPYING3. If not see #include "gfortran.h" #include "match.h" #include "parse.h" -#include "flags.h" +#include "options.h" #include "constructor.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" #include "stringpool.h" @@ -910,7 +902,35 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) sym = *result; - if (sym && !sym->gfc_new && gfc_current_state () != COMP_INTERFACE) + if (sym->attr.module_procedure + && sym->attr.if_source == IFSRC_IFBODY) + { + /* Create a partially populated interface symbol to carry the + characteristics of the procedure and the result. */ + sym->ts.interface = gfc_new_symbol (name, sym->ns); + gfc_add_type (sym->ts.interface, &(sym->ts), + &gfc_current_locus); + gfc_copy_attr (&sym->ts.interface->attr, &sym->attr, NULL); + if (sym->attr.dimension) + sym->ts.interface->as = gfc_copy_array_spec (sym->as); + + /* Ideally, at this point, a copy would be made of the formal + arguments and their namespace. However, this does not appear + to be necessary, albeit at the expense of not being able to + use gfc_compare_interfaces directly. */ + + if (sym->result && sym->result != sym) + { + sym->ts.interface->result = sym->result; + sym->result = NULL; + } + else if (sym->result) + { + sym->ts.interface->result = sym->ts.interface; + } + } + else if (sym && !sym->gfc_new + && gfc_current_state () != COMP_INTERFACE) { /* Trap another encompassed procedure with the same name. All these conditions are necessary to avoid picking up an entry @@ -921,17 +941,17 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) && sym->attr.proc != 0 && (sym->attr.subroutine || sym->attr.function) && sym->attr.if_source != IFSRC_UNKNOWN) - gfc_error_now_1 ("Procedure '%s' at %C is already defined at %L", - name, &sym->declared_at); + gfc_error_now ("Procedure %qs at %C is already defined at %L", + name, &sym->declared_at); /* Trap a procedure with a name the same as interface in the encompassing scope. */ if (sym->attr.generic != 0 && (sym->attr.subroutine || sym->attr.function) && !sym->attr.mod_proc) - gfc_error_now_1 ("Name '%s' at %C is already defined" - " as a generic interface at %L", - name, &sym->declared_at); + gfc_error_now ("Name %qs at %C is already defined" + " as a generic interface at %L", + name, &sym->declared_at); /* Trap declarations of attributes in encompassing scope. The signature for this is that ts.kind is set. Legitimate @@ -942,9 +962,9 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) && gfc_current_ns->parent != NULL && sym->attr.access == 0 && !module_fcn_entry) - gfc_error_now_1 ("Procedure '%s' at %C has an explicit interface " - "and must not have attributes declared at %L", - name, &sym->declared_at); + gfc_error_now ("Procedure %qs at %C has an explicit interface " + "and must not have attributes declared at %L", + name, &sym->declared_at); } if (gfc_current_ns->parent == NULL || *result == NULL) @@ -1126,7 +1146,7 @@ gfc_verify_c_interop_param (gfc_symbol *sym) either assumed size or explicit shape. Deferred shape is already covered by the pointer/allocatable attribute. */ if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE - && !gfc_notify_std_1 (GFC_STD_F2008_TS, "Assumed-shape array '%s' " + && !gfc_notify_std (GFC_STD_F2008_TS, "Assumed-shape array %qs " "at %L as dummy argument to the BIND(C) " "procedure '%s' at %L", sym->name, &(sym->declared_at), @@ -1404,9 +1424,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) } else if (init->expr_type == EXPR_ARRAY) { - gfc_constructor *c; - c = gfc_constructor_first (init->value.constructor); - clen = c->expr->value.character.length; + clen = mpz_get_si (init->ts.u.cl->length->value.integer); sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, clen); @@ -1927,6 +1945,23 @@ variable_decl (int elem) } } + /* The dummy arguments and result of the abreviated form of MODULE + PROCEDUREs, used in SUBMODULES should not be redefined. */ + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->abr_modproc_decl) + { + gfc_find_symbol (name, gfc_current_ns, 1, &sym); + if (sym != NULL && (sym->attr.dummy || sym->attr.result)) + { + m = MATCH_ERROR; + gfc_error ("'%s' at %C is a redefinition of the declaration " + "in the corresponding interface for MODULE " + "PROCEDURE '%s'", sym->name, + gfc_current_ns->proc_name->name); + goto cleanup; + } + } + /* If this symbol has already shown up in a Cray Pointer declaration, and this is not a component declaration, then we want to set the type & bail out. */ @@ -2870,9 +2905,9 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic)) || sym->attr.subroutine) { - gfc_error_1 ("Type name '%s' at %C conflicts with previously declared " - "entity at %L, which has the same name", name, - &sym->declared_at); + gfc_error ("Type name %qs at %C conflicts with previously declared " + "entity at %L, which has the same name", name, + &sym->declared_at); return MATCH_ERROR; } @@ -3271,6 +3306,13 @@ gfc_match_import (void) return MATCH_ERROR; } + if (gfc_current_ns->proc_name->attr.module_procedure) + { + gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted " + "in a module procedure interface body"); + return MATCH_ERROR; + } + if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C")) return MATCH_ERROR; @@ -3934,7 +3976,9 @@ match_attr_spec (void) } /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */ - if (gfc_current_state () == COMP_MODULE && !current_attr.save + if ((gfc_current_state () == COMP_MODULE + || gfc_current_state () == COMP_SUBMODULE) + && !current_attr.save && (gfc_option.allow_std & GFC_STD_F2008) != 0) current_attr.save = SAVE_IMPLICIT; @@ -4522,6 +4566,22 @@ gfc_match_prefix (gfc_typespec *ts) /* At this point, the next item is not a prefix. */ gcc_assert (gfc_matching_prefix); + + /* MODULE should be the last prefix before FUNCTION or SUBROUTINE. + Since this is a prefix like PURE, ELEMENTAL, etc., having a + corresponding attribute seems natural and distinguishes these + procedures from procedure types of PROC_MODULE, which these are + as well. */ + if ((gfc_current_state () == COMP_INTERFACE + || gfc_current_state () == COMP_CONTAINS) + && gfc_match ("module% ") == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C")) + goto error; + else + current_attr.module_procedure = 1; + } + gfc_matching_prefix = false; return MATCH_YES; @@ -4559,9 +4619,24 @@ gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag) char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_symbol *sym; match m; + gfc_formal_arglist *formal = NULL; head = tail = NULL; + /* Keep the interface formal argument list and null it so that the + matching for the new declaration can be done. The numbers and + names of the arguments are checked here. The interface formal + arguments are retained in formal_arglist and the characteristics + are compared in resolve.c(resolve_fl_procedure). See the remark + in get_proc_name about the eventual need to copy the formal_arglist + and populate the formal namespace of the interface symbol. */ + if (progname->attr.module_procedure + && progname->attr.host_assoc) + { + formal = progname->formal; + progname->formal = NULL; + } + if (gfc_match_char ('(') != MATCH_YES) { if (null_flag) @@ -4667,6 +4742,24 @@ ok: goto cleanup; } + if (formal) + { + for (p = formal, q = head; p && q; p = p->next, q = q->next) + { + if ((p->next != NULL && q->next == NULL) + || (p->next == NULL && q->next != NULL)) + gfc_error_now ("Mismatch in number of MODULE PROCEDURE " + "formal arguments at %C"); + else if ((p->sym == NULL && q->sym == NULL) + || strcmp (p->sym->name, q->sym->name) == 0) + continue; + else + gfc_error_now ("Mismatch in MODULE PROCEDURE formal " + "argument names (%s/%s) at %C", + p->sym->name, q->sym->name); + } + } + return MATCH_YES; cleanup: @@ -5280,6 +5373,7 @@ gfc_match_procedure (void) case COMP_NONE: case COMP_PROGRAM: case COMP_MODULE: + case COMP_SUBMODULE: case COMP_SUBROUTINE: case COMP_FUNCTION: case COMP_BLOCK: @@ -5318,7 +5412,8 @@ do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func) bool in_module; in_module = (gfc_state_stack->previous - && gfc_state_stack->previous->state == COMP_MODULE); + && (gfc_state_stack->previous->state == COMP_MODULE + || gfc_state_stack->previous->state == COMP_SUBMODULE)); gfc_warn_intrinsic_shadow (sym, in_module, func); } @@ -5357,12 +5452,16 @@ gfc_match_function_decl (void) gfc_current_locus = old_loc; return MATCH_NO; } + if (get_proc_name (name, &sym, false)) return MATCH_ERROR; if (add_hidden_procptr_result (sym)) sym = sym->result; + if (current_attr.module_procedure) + sym->attr.module_procedure = 1; + gfc_new_block = sym; m = gfc_match_formal_arglist (sym, 0, 0); @@ -5556,6 +5655,9 @@ gfc_match_entry (void) case COMP_MODULE: gfc_error ("ENTRY statement at %C cannot appear within a MODULE"); break; + case COMP_SUBMODULE: + gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE"); + break; case COMP_BLOCK_DATA: gfc_error ("ENTRY statement at %C cannot appear within " "a BLOCK DATA"); @@ -5594,7 +5696,7 @@ gfc_match_entry (void) "a contained subprogram"); break; default: - gfc_internal_error ("gfc_match_entry(): Bad state"); + gfc_error ("Unexpected ENTRY statement at %C"); } return MATCH_ERROR; } @@ -5800,6 +5902,9 @@ gfc_match_subroutine (void) the symbol existed before. */ sym->declared_at = gfc_current_locus; + if (current_attr.module_procedure) + sym->attr.module_procedure = 1; + if (add_hidden_procptr_result (sym)) sym = sym->result; @@ -6123,6 +6228,7 @@ gfc_match_end (gfc_statement *st) match m; gfc_namespace *parent_ns, *ns, *prev_ns; gfc_namespace **nsp; + bool abreviated_modproc_decl; old_loc = gfc_current_locus; if (gfc_match ("end") != MATCH_YES) @@ -6151,6 +6257,10 @@ gfc_match_end (gfc_statement *st) break; } + abreviated_modproc_decl + = gfc_current_block () + && gfc_current_block ()->abr_modproc_decl; + switch (state) { case COMP_NONE: @@ -6162,13 +6272,19 @@ gfc_match_end (gfc_statement *st) case COMP_SUBROUTINE: *st = ST_END_SUBROUTINE; + if (!abreviated_modproc_decl) target = " subroutine"; + else + target = " procedure"; eos_ok = !contained_procedure (); break; case COMP_FUNCTION: *st = ST_END_FUNCTION; + if (!abreviated_modproc_decl) target = " function"; + else + target = " procedure"; eos_ok = !contained_procedure (); break; @@ -6184,6 +6300,12 @@ gfc_match_end (gfc_statement *st) eos_ok = 1; break; + case COMP_SUBMODULE: + *st = ST_END_SUBMODULE; + target = " submodule"; + eos_ok = 1; + break; + case COMP_INTERFACE: *st = ST_END_INTERFACE; target = " interface"; @@ -6268,7 +6390,8 @@ gfc_match_end (gfc_statement *st) { if (!gfc_notify_std (GFC_STD_F2008, "END statement " "instead of %s statement at %L", - gfc_ascii_statement(*st), &old_loc)) + abreviated_modproc_decl ? "END PROCEDURE" + : gfc_ascii_statement(*st), &old_loc)) goto cleanup; } else if (!eos_ok) @@ -6285,8 +6408,8 @@ gfc_match_end (gfc_statement *st) /* Verify that we've got the sort of end-block that we're expecting. */ if (gfc_match (target) != MATCH_YES) { - gfc_error ("Expecting %s statement at %L", gfc_ascii_statement (*st), - &old_loc); + gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl + ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc); goto cleanup; } @@ -6327,6 +6450,11 @@ gfc_match_end (gfc_statement *st) if (block_name == NULL) goto syntax; + /* We have to pick out the declared submodule name from the composite + required by F2008:11.2.3 para 2, which ends in the declared name. */ + if (state == COMP_SUBMODULE) + block_name = strchr (block_name, '.') + 1; + if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0) { gfc_error ("Expected label %qs for %s statement at %C", block_name, @@ -6970,7 +7098,8 @@ gfc_match_protected (void) gfc_symbol *sym; match m; - if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE) + if (!gfc_current_ns->proc_name + || gfc_current_ns->proc_name->attr.flavor != FL_MODULE) { gfc_error ("PROTECTED at %C only allowed in specification " "part of a module"); @@ -7425,6 +7554,99 @@ syntax: } +/* Match a module procedure statement in a submodule. */ + +match +gfc_match_submod_proc (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym, *fsym; + match m; + gfc_formal_arglist *formal, *head, *tail; + + if (gfc_current_state () != COMP_CONTAINS + || !(gfc_state_stack->previous + && gfc_state_stack->previous->state == COMP_SUBMODULE)) + return MATCH_NO; + + m = gfc_match (" module% procedure% %n", name); + if (m != MATCH_YES) + return m; + + if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration " + "at %C")) + return MATCH_ERROR; + + if (get_proc_name (name, &sym, false)) + return MATCH_ERROR; + + /* Make sure that the result field is appropriately filled, even though + the result symbol will be replaced later on. */ + if (sym->ts.interface->attr.function) + { + if (sym->ts.interface->result + && sym->ts.interface->result != sym->ts.interface) + sym->result= sym->ts.interface->result; + else + sym->result = sym; + } + + /* Set declared_at as it might point to, e.g., a PUBLIC statement, if + the symbol existed before. */ + sym->declared_at = gfc_current_locus; + + if (!sym->attr.module_procedure) + return MATCH_ERROR; + + /* Signal match_end to expect "end procedure". */ + sym->abr_modproc_decl = 1; + + /* Change from IFSRC_IFBODY coming from the interface declaration. */ + sym->attr.if_source = IFSRC_DECL; + + gfc_new_block = sym; + + /* Make a new formal arglist with the symbols in the procedure + namespace. */ + head = tail = NULL; + for (formal = sym->formal; formal && formal->sym; formal = formal->next) + { + if (formal == sym->formal) + head = tail = gfc_get_formal_arglist (); + else + { + tail->next = gfc_get_formal_arglist (); + tail = tail->next; + } + + if (gfc_copy_dummy_sym (&fsym, formal->sym, 0)) + goto cleanup; + + tail->sym = fsym; + gfc_set_sym_referenced (fsym); + } + + /* The dummy symbols get cleaned up, when the formal_namespace of the + interface declaration is cleared. This allows us to add the + explicit interface as is done for other type of procedure. */ + if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head, + &gfc_current_locus)) + return MATCH_ERROR; + + if (gfc_match_eos () != MATCH_YES) + { + gfc_syntax_error (ST_MODULE_PROC); + return MATCH_ERROR; + } + + return MATCH_YES; + +cleanup: + gfc_free_formal_arglist (head); + return MATCH_ERROR; +} + + /* Match a module procedure statement. Note that we have to modify symbols in the parent's namespace because the current one was there to receive symbols that are in an interface's formal argument list. */ @@ -8512,6 +8734,11 @@ gfc_match_generic (void) gfc_op2string (op)); break; + case INTERFACE_NAMELESS: + gfc_error ("Malformed GENERIC statement at %C"); + goto error; + break; + default: gcc_unreachable (); } diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index 63c66303497..8b07f59586a 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -956,7 +956,7 @@ gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent, If a dependency is found in the case elemental == ELEM_CHECK_VARIABLE, we will generate a temporary, so we don't need to bother the user. */ - gfc_warning_1 ("INTENT(%s) actual argument at %L might " + gfc_warning (0, "INTENT(%s) actual argument at %L might " "interfere with actual argument at %L.", intent == INTENT_OUT ? "OUT" : "INOUT", &var->where, &expr->where); diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c index da0eb8f664e..7689bbd8941 100644 --- a/gcc/fortran/error.c +++ b/gcc/fortran/error.c @@ -27,7 +27,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "flags.h" +#include "options.h" #include "gfortran.h" #include "diagnostic.h" @@ -40,12 +40,12 @@ static int suppress_errors = 0; static bool warnings_not_errors = false; -static int terminal_width, errors, warnings; - -static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer; +static int terminal_width; /* True if the error/warnings should be buffered. */ static bool buffered_p; + +static gfc_error_buffer error_buffer; /* These are always buffered buffers (.flush_p == false) to be used by the pretty-printer. */ static output_buffer *pp_error_buffer, *pp_warning_buffer; @@ -100,8 +100,6 @@ void gfc_error_init_1 (void) { terminal_width = gfc_get_terminal_width (); - errors = 0; - warnings = 0; gfc_buffer_error (false); } @@ -119,42 +117,9 @@ gfc_buffer_error (bool flag) buffered_p. */ static void -error_char (char c) +error_char (char) { - if (buffered_p) - { - if (cur_error_buffer->index >= cur_error_buffer->allocated) - { - cur_error_buffer->allocated = cur_error_buffer->allocated - ? cur_error_buffer->allocated * 2 : 1000; - cur_error_buffer->message = XRESIZEVEC (char, cur_error_buffer->message, - cur_error_buffer->allocated); - } - cur_error_buffer->message[cur_error_buffer->index++] = c; - } - else - { - if (c != 0) - { - /* We build up complete lines before handing things - over to the library in order to speed up error printing. */ - static char *line; - static size_t allocated = 0, index = 0; - - if (index + 1 >= allocated) - { - allocated = allocated ? allocated * 2 : 1000; - line = XRESIZEVEC (char, line, allocated); - } - line[index++] = c; - if (c == '\n') - { - line[index] = '\0'; - fputs (line, stderr); - index = 0; - } - } - } + /* FIXME: Unused function to be removed in a subsequent patch. */ } @@ -782,18 +747,6 @@ error_printf (const char *gmsgid, ...) } -/* Increment the number of errors, and check whether too many have - been printed. */ - -static void -gfc_increment_error_count (void) -{ - errors++; - if ((gfc_option.max_errors != 0) && (errors >= gfc_option.max_errors)) - gfc_fatal_error ("Error count reached limit of %d.", gfc_option.max_errors); -} - - /* Clear any output buffered in a pretty-print output_buffer. */ static void @@ -807,37 +760,6 @@ gfc_clear_pp_buffer (output_buffer *this_buffer) } -/* Issue a warning. */ -/* Use gfc_warning instead, unless two locations are used in the same - warning or for scanner.c, if the location is not properly set up. */ - -void -gfc_warning_1 (const char *gmsgid, ...) -{ - va_list argp; - - if (inhibit_warnings) - return; - - warning_buffer.flag = 1; - warning_buffer.index = 0; - cur_error_buffer = &warning_buffer; - - va_start (argp, gmsgid); - error_print (_("Warning:"), _(gmsgid), argp); - va_end (argp); - - error_char ('\0'); - - if (!buffered_p) - { - warnings++; - if (warnings_are_errors) - gfc_increment_error_count(); - } -} - - /* This is just a helper function to avoid duplicating the logic of gfc_warning. */ @@ -889,9 +811,6 @@ gfc_warning (int opt, const char *gmsgid, va_list ap) } /* Issue a warning. */ -/* This function uses the common diagnostics, but does not support - two locations; when being used in scanner.c, ensure that the location - is properly setup. Otherwise, use gfc_warning_1. */ bool gfc_warning (int opt, const char *gmsgid, ...) @@ -927,84 +846,6 @@ gfc_notification_std (int std) an error is generated. */ bool -gfc_notify_std_1 (int std, const char *gmsgid, ...) -{ - va_list argp; - bool warning; - const char *msg1, *msg2; - char *buffer; - - warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings; - if ((gfc_option.allow_std & std) != 0 && !warning) - return true; - - if (suppress_errors) - return warning ? true : false; - - cur_error_buffer = warning ? &warning_buffer : &error_buffer; - cur_error_buffer->flag = 1; - cur_error_buffer->index = 0; - - if (warning) - msg1 = _("Warning:"); - else - msg1 = _("Error:"); - - switch (std) - { - case GFC_STD_F2008_TS: - msg2 = "TS 29113/TS 18508:"; - break; - case GFC_STD_F2008_OBS: - msg2 = _("Fortran 2008 obsolescent feature:"); - break; - case GFC_STD_F2008: - msg2 = "Fortran 2008:"; - break; - case GFC_STD_F2003: - msg2 = "Fortran 2003:"; - break; - case GFC_STD_GNU: - msg2 = _("GNU Extension:"); - break; - case GFC_STD_LEGACY: - msg2 = _("Legacy Extension:"); - break; - case GFC_STD_F95_OBS: - msg2 = _("Obsolescent feature:"); - break; - case GFC_STD_F95_DEL: - msg2 = _("Deleted feature:"); - break; - default: - gcc_unreachable (); - } - - buffer = (char *) alloca (strlen (msg1) + strlen (msg2) + 2); - strcpy (buffer, msg1); - strcat (buffer, " "); - strcat (buffer, msg2); - - va_start (argp, gmsgid); - error_print (buffer, _(gmsgid), argp); - va_end (argp); - - error_char ('\0'); - - if (!buffered_p) - { - if (warning && !warnings_are_errors) - warnings++; - else - gfc_increment_error_count(); - cur_error_buffer->flag = 0; - } - - return (warning && !warnings_are_errors) ? true : false; -} - - -bool gfc_notify_std (int std, const char *gmsgid, ...) { va_list argp; @@ -1066,35 +907,6 @@ gfc_notify_std (int std, const char *gmsgid, ...) } -/* Immediate warning (i.e. do not buffer the warning). */ -/* Use gfc_warning_now instead, unless two locations are used in the same - warning or for scanner.c, if the location is not properly set up. */ - -void -gfc_warning_now_1 (const char *gmsgid, ...) -{ - va_list argp; - bool buffered_p_saved; - - if (inhibit_warnings) - return; - - buffered_p_saved = buffered_p; - buffered_p = false; - warnings++; - - va_start (argp, gmsgid); - error_print (_("Warning:"), _(gmsgid), argp); - va_end (argp); - - error_char ('\0'); - - if (warnings_are_errors) - gfc_increment_error_count(); - - buffered_p = buffered_p_saved; -} - /* Called from output_format -- during diagnostic message processing to handle Fortran specific format specifiers with the following meanings: @@ -1112,7 +924,7 @@ gfc_format_decoder (pretty_printer *pp, case 'C': case 'L': { - static const char *result = "(1)"; + static const char *result[2] = { "(1)", "(2)" }; locus *loc; if (*spec == 'C') loc = &gfc_current_locus; @@ -1120,13 +932,14 @@ gfc_format_decoder (pretty_printer *pp, loc = va_arg (*text->args_ptr, locus *); gcc_assert (loc->nextc - loc->lb->line >= 0); unsigned int offset = loc->nextc - loc->lb->line; - gcc_assert (text->locus); - *text->locus - = linemap_position_for_loc_and_offset (line_table, - loc->lb->location, - offset); - global_dc->caret_char = '1'; - pp_string (pp, result); + /* If location[0] != UNKNOWN_LOCATION means that we already + processed one of %C/%L. */ + int loc_num = text->get_location (0) == UNKNOWN_LOCATION ? 0 : 1; + text->set_location (loc_num, + linemap_position_for_loc_and_offset (line_table, + loc->lb->location, + offset)); + pp_string (pp, result[loc_num]); return true; } default: @@ -1134,11 +947,11 @@ gfc_format_decoder (pretty_printer *pp, } } -/* Return a malloc'd string describing a location. The caller is - responsible for freeing the memory. */ +/* Return a malloc'd string describing the kind of diagnostic. The + caller is responsible for freeing the memory. */ static char * -gfc_diagnostic_build_prefix (diagnostic_context *context, - const diagnostic_info *diagnostic) +gfc_diagnostic_build_kind_prefix (diagnostic_context *context, + const diagnostic_info *diagnostic) { static const char *const diagnostic_kind_text[] = { #define DEFINE_DIAGNOSTIC_KIND(K, T, C) (T), @@ -1170,12 +983,11 @@ gfc_diagnostic_build_prefix (diagnostic_context *context, responsible for freeing the memory. */ static char * gfc_diagnostic_build_locus_prefix (diagnostic_context *context, - const diagnostic_info *diagnostic) + expanded_location s) { pretty_printer *pp = context->printer; const char *locus_cs = colorize_start (pp_show_color (pp), "locus"); const char *locus_ce = colorize_stop (pp_show_color (pp)); - expanded_location s = diagnostic_expand_location (diagnostic); return (s.file == NULL ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce ) : !strcmp (s.file, N_("<built-in>")) @@ -1186,35 +998,160 @@ gfc_diagnostic_build_locus_prefix (diagnostic_context *context, : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line, locus_ce)); } -static void +/* Return a malloc'd string describing two locations. The caller is + responsible for freeing the memory. */ +static char * +gfc_diagnostic_build_locus_prefix (diagnostic_context *context, + expanded_location s, expanded_location s2) +{ + pretty_printer *pp = context->printer; + const char *locus_cs = colorize_start (pp_show_color (pp), "locus"); + const char *locus_ce = colorize_stop (pp_show_color (pp)); + + return (s.file == NULL + ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce ) + : !strcmp (s.file, N_("<built-in>")) + ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce) + : context->show_column + ? build_message_string ("%s%s:%d:%d-%d:%s", locus_cs, s.file, s.line, + MIN (s.column, s2.column), + MAX (s.column, s2.column), locus_ce) + : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line, + locus_ce)); +} + +/* This function prints the locus (file:line:column), the diagnostic kind + (Error, Warning) and (optionally) the caret line (a source line + with '1' and/or '2' below it). + + With -fdiagnostic-show-caret (the default) and for valid locations, + it prints for one location: + + [locus]: + + some code + 1 + Error: Some error at (1) + + for two locations that fit in the same locus line: + + [locus]: + + some code and some more code + 1 2 + Error: Some error at (1) and (2) + + and for two locations that do not fit in the same locus line: + + [locus]: + + some code + 1 + [locus2]: + + some other code + 2 + Error: Some error at (1) and (2) + + With -fno-diagnostic-show-caret or if one of the locations is not + valid, it prints for one location (or for two locations that fit in + the same locus line): + + [locus]: Error: Some error at (1) and (2) + + and for two locations that do not fit in the same locus line: + + [name]:[locus]: Error: (1) + [name]:[locus2]: Error: Some error at (1) and (2) +*/ +static void gfc_diagnostic_starter (diagnostic_context *context, diagnostic_info *diagnostic) { - char * locus_prefix = gfc_diagnostic_build_locus_prefix (context, diagnostic); - char * prefix = gfc_diagnostic_build_prefix (context, diagnostic); - /* First we assume there is a caret line. */ - pp_set_prefix (context->printer, NULL); - if (pp_needs_newline (context->printer)) - pp_newline (context->printer); - pp_verbatim (context->printer, locus_prefix); - /* Fortran uses an empty line between locus and caret line. */ - pp_newline (context->printer); - diagnostic_show_locus (context, diagnostic); - if (pp_needs_newline (context->printer)) + char * kind_prefix = gfc_diagnostic_build_kind_prefix (context, diagnostic); + + expanded_location s1 = diagnostic_expand_location (diagnostic); + expanded_location s2; + bool one_locus = diagnostic_location (diagnostic, 1) == UNKNOWN_LOCATION; + bool same_locus = false; + + if (!one_locus) + { + s2 = diagnostic_expand_location (diagnostic, 1); + same_locus = diagnostic_same_line (context, s1, s2); + } + + char * locus_prefix = (one_locus || !same_locus) + ? gfc_diagnostic_build_locus_prefix (context, s1) + : gfc_diagnostic_build_locus_prefix (context, s1, s2); + + if (!context->show_caret + || diagnostic_location (diagnostic, 0) <= BUILTINS_LOCATION + || diagnostic_location (diagnostic, 0) == context->last_location) { + pp_set_prefix (context->printer, + concat (locus_prefix, " ", kind_prefix, NULL)); + free (locus_prefix); + + if (one_locus || same_locus) + { + free (kind_prefix); + return; + } + /* In this case, we print the previous locus and prefix as: + + [locus]:[prefix]: (1) + + and we flush with a new line before setting the new prefix. */ + pp_string (context->printer, "(1)"); pp_newline (context->printer); - /* If the caret line was shown, the prefix does not contain the - locus. */ - pp_set_prefix (context->printer, prefix); + locus_prefix = gfc_diagnostic_build_locus_prefix (context, s2); + pp_set_prefix (context->printer, + concat (locus_prefix, " ", kind_prefix, NULL)); + free (kind_prefix); + free (locus_prefix); } - else + else { - /* Otherwise, start again. */ - pp_clear_output_area(context->printer); - pp_set_prefix (context->printer, concat (locus_prefix, " ", prefix, NULL)); - free (prefix); + pp_verbatim (context->printer, locus_prefix); + free (locus_prefix); + /* Fortran uses an empty line between locus and caret line. */ + pp_newline (context->printer); + diagnostic_show_locus (context, diagnostic); + pp_newline (context->printer); + /* If the caret line was shown, the prefix does not contain the + locus. */ + pp_set_prefix (context->printer, kind_prefix); + + if (one_locus || same_locus) + return; + + locus_prefix = gfc_diagnostic_build_locus_prefix (context, s2); + if (diagnostic_location (diagnostic, 1) <= BUILTINS_LOCATION) + { + /* No caret line for the second location. Override the previous + prefix with [locus2]:[prefix]. */ + pp_set_prefix (context->printer, + concat (locus_prefix, " ", kind_prefix, NULL)); + free (kind_prefix); + free (locus_prefix); + } + else + { + /* We print the caret for the second location. */ + pp_verbatim (context->printer, locus_prefix); + free (locus_prefix); + /* Fortran uses an empty line between locus and caret line. */ + pp_newline (context->printer); + s1.column = 0; /* Print only a caret line for s2. */ + diagnostic_print_caret_line (context, s2, s1, + context->caret_chars[1], '\0'); + pp_newline (context->printer); + /* If the caret line was shown, the prefix does not contain the + locus. */ + pp_set_prefix (context->printer, kind_prefix); + } } - free (locus_prefix); } static void @@ -1225,10 +1162,25 @@ gfc_diagnostic_finalizer (diagnostic_context *context, pp_newline_and_flush (context->printer); } +/* Immediate warning (i.e. do not buffer the warning) with an explicit + location. */ + +bool +gfc_warning_now_at (location_t loc, int opt, const char *gmsgid, ...) +{ + va_list argp; + diagnostic_info diagnostic; + bool ret; + + va_start (argp, gmsgid); + diagnostic_set_info (&diagnostic, gmsgid, &argp, loc, DK_WARNING); + diagnostic.option_index = opt; + ret = report_diagnostic (&diagnostic); + va_end (argp); + return ret; +} + /* Immediate warning (i.e. do not buffer the warning). */ -/* This function uses the common diagnostics, but does not support - two locations; when being used in scanner.c, ensure that the location - is properly setup. Otherwise, use gfc_warning_now_1. */ bool gfc_warning_now (int opt, const char *gmsgid, ...) @@ -1248,9 +1200,6 @@ gfc_warning_now (int opt, const char *gmsgid, ...) /* Immediate error (i.e. do not buffer). */ -/* This function uses the common diagnostics, but does not support - two locations; when being used in scanner.c, ensure that the location - is properly setup. Otherwise, use gfc_error_now_1. */ void gfc_error_now (const char *gmsgid, ...) @@ -1258,6 +1207,8 @@ gfc_error_now (const char *gmsgid, ...) va_list argp; diagnostic_info diagnostic; + error_buffer.flag = true; + va_start (argp, gmsgid); diagnostic_set_info (&diagnostic, gmsgid, &argp, UNKNOWN_LOCATION, DK_ERROR); report_diagnostic (&diagnostic); @@ -1286,8 +1237,6 @@ gfc_fatal_error (const char *gmsgid, ...) void gfc_clear_warning (void) { - warning_buffer.flag = 0; - gfc_clear_pp_buffer (pp_warning_buffer); warningcount_buffered = 0; werrorcount_buffered = 0; @@ -1300,15 +1249,7 @@ gfc_clear_warning (void) void gfc_warning_check (void) { - if (warning_buffer.flag) - { - warnings++; - if (warning_buffer.message != NULL) - fputs (warning_buffer.message, stderr); - gfc_clear_warning (); - } - /* This is for the new diagnostics machinery. */ - else if (! gfc_output_buffer_empty_p (pp_warning_buffer)) + if (! gfc_output_buffer_empty_p (pp_warning_buffer)) { pretty_printer *pp = global_dc->printer; output_buffer *tmp_buffer = pp->buffer; @@ -1317,71 +1258,15 @@ gfc_warning_check (void) warningcount += warningcount_buffered; werrorcount += werrorcount_buffered; gcc_assert (warningcount_buffered + werrorcount_buffered == 1); + pp->buffer = tmp_buffer; diagnostic_action_after_output (global_dc, warningcount_buffered ? DK_WARNING : DK_ERROR); - pp->buffer = tmp_buffer; } } /* Issue an error. */ -/* Use gfc_error instead, unless two locations are used in the same - warning or for scanner.c, if the location is not properly set up. */ - -void -gfc_error_1 (const char *gmsgid, ...) -{ - va_list argp; - - if (warnings_not_errors) - goto warning; - - if (suppress_errors) - return; - - error_buffer.flag = 1; - error_buffer.index = 0; - cur_error_buffer = &error_buffer; - - va_start (argp, gmsgid); - error_print (_("Error:"), _(gmsgid), argp); - va_end (argp); - - error_char ('\0'); - - if (!buffered_p) - gfc_increment_error_count(); - - return; - -warning: - - if (inhibit_warnings) - return; - - warning_buffer.flag = 1; - warning_buffer.index = 0; - cur_error_buffer = &warning_buffer; - - va_start (argp, gmsgid); - error_print (_("Warning:"), _(gmsgid), argp); - va_end (argp); - - error_char ('\0'); - - if (!buffered_p) - { - warnings++; - if (warnings_are_errors) - gfc_increment_error_count(); - } -} - -/* Issue an error. */ -/* This function uses the common diagnostics, but does not support - two locations; when being used in scanner.c, ensure that the location - is properly setup. Otherwise, use gfc_error_1. */ static void gfc_error (const char *gmsgid, va_list ap) @@ -1441,38 +1326,6 @@ gfc_error (const char *gmsgid, ...) } -/* Immediate error. */ -/* Use gfc_error_now instead, unless two locations are used in the same - warning or for scanner.c, if the location is not properly set up. */ - -void -gfc_error_now_1 (const char *gmsgid, ...) -{ - va_list argp; - bool buffered_p_saved; - - error_buffer.flag = 1; - error_buffer.index = 0; - cur_error_buffer = &error_buffer; - - buffered_p_saved = buffered_p; - buffered_p = false; - - va_start (argp, gmsgid); - error_print (_("Error:"), _(gmsgid), argp); - va_end (argp); - - error_char ('\0'); - - gfc_increment_error_count(); - - buffered_p = buffered_p_saved; - - if (flag_fatal_errors) - exit (FATAL_EXIT_CODE); -} - - /* This shouldn't happen... but sometimes does. */ void @@ -1517,35 +1370,22 @@ gfc_error_flag_test (void) bool gfc_error_check (void) { - bool error_raised = (bool) error_buffer.flag; - - if (error_raised) + if (error_buffer.flag + || ! gfc_output_buffer_empty_p (pp_error_buffer)) { - if (error_buffer.message != NULL) - fputs (error_buffer.message, stderr); - error_buffer.flag = 0; - gfc_clear_pp_buffer (pp_error_buffer); - - gfc_increment_error_count(); - - if (flag_fatal_errors) - exit (FATAL_EXIT_CODE); - } - /* This is for the new diagnostics machinery. */ - else if (! gfc_output_buffer_empty_p (pp_error_buffer)) - { - error_raised = true; + error_buffer.flag = false; pretty_printer *pp = global_dc->printer; output_buffer *tmp_buffer = pp->buffer; pp->buffer = pp_error_buffer; pp_really_flush (pp); ++errorcount; gcc_assert (gfc_output_buffer_empty_p (pp_error_buffer)); - diagnostic_action_after_output (global_dc, DK_ERROR); pp->buffer = tmp_buffer; + diagnostic_action_after_output (global_dc, DK_ERROR); + return true; } - return error_raised; + return false; } /* Move the text buffered from FROM to TO, then clear @@ -1553,8 +1393,15 @@ gfc_error_check (void) cleared. */ static void -gfc_move_output_buffer_from_to (output_buffer *from, output_buffer *to) +gfc_move_error_buffer_from_to (gfc_error_buffer * buffer_from, + gfc_error_buffer * buffer_to) { + output_buffer * from = &(buffer_from->buffer); + output_buffer * to = &(buffer_to->buffer); + + buffer_to->flag = buffer_from->flag; + buffer_from->flag = false; + gfc_clear_pp_buffer (to); /* We make sure this is always buffered. */ to->flush_p = false; @@ -1570,46 +1417,27 @@ gfc_move_output_buffer_from_to (output_buffer *from, output_buffer *to) /* Save the existing error state. */ void -gfc_push_error (output_buffer *buffer_err, gfc_error_buf *err) +gfc_push_error (gfc_error_buffer *err) { - err->flag = error_buffer.flag; - if (error_buffer.flag) - err->message = xstrdup (error_buffer.message); - - error_buffer.flag = 0; - - /* This part uses the common diagnostics. */ - gfc_move_output_buffer_from_to (pp_error_buffer, buffer_err); + gfc_move_error_buffer_from_to (&error_buffer, err); } /* Restore a previous pushed error state. */ void -gfc_pop_error (output_buffer *buffer_err, gfc_error_buf *err) +gfc_pop_error (gfc_error_buffer *err) { - error_buffer.flag = err->flag; - if (error_buffer.flag) - { - size_t len = strlen (err->message) + 1; - gcc_assert (len <= error_buffer.allocated); - memcpy (error_buffer.message, err->message, len); - free (err->message); - } - /* This part uses the common diagnostics. */ - gfc_move_output_buffer_from_to (buffer_err, pp_error_buffer); + gfc_move_error_buffer_from_to (err, &error_buffer); } /* Free a pushed error state, but keep the current error state. */ void -gfc_free_error (output_buffer *buffer_err, gfc_error_buf *err) +gfc_free_error (gfc_error_buffer *err) { - if (err->flag) - free (err->message); - - gfc_clear_pp_buffer (buffer_err); + gfc_clear_pp_buffer (&(err->buffer)); } @@ -1619,9 +1447,9 @@ void gfc_get_errors (int *w, int *e) { if (w != NULL) - *w = warnings + warningcount + werrorcount; + *w = warningcount + werrorcount; if (e != NULL) - *e = errors + errorcount + sorrycount + werrorcount; + *e = errorcount + sorrycount + werrorcount; } @@ -1639,10 +1467,13 @@ gfc_diagnostics_init (void) diagnostic_starter (global_dc) = gfc_diagnostic_starter; diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer; diagnostic_format_decoder (global_dc) = gfc_format_decoder; - global_dc->caret_char = '^'; + global_dc->caret_chars[0] = '1'; + global_dc->caret_chars[1] = '2'; pp_warning_buffer = new (XNEW (output_buffer)) output_buffer (); pp_warning_buffer->flush_p = false; - pp_error_buffer = new (XNEW (output_buffer)) output_buffer (); + /* pp_error_buffer is statically allocated. This simplifies memory + management when using gfc_push/pop_error. */ + pp_error_buffer = &(error_buffer.buffer); pp_error_buffer->flush_p = false; } @@ -1654,5 +1485,6 @@ gfc_diagnostics_finish (void) defaults. */ diagnostic_starter (global_dc) = gfc_diagnostic_starter; diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer; - global_dc->caret_char = '^'; + global_dc->caret_chars[0] = '^'; + global_dc->caret_chars[1] = '^'; } diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index ab6f7a52205..9e5a804f70d 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -21,7 +21,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "flags.h" +#include "options.h" #include "gfortran.h" #include "arith.h" #include "match.h" @@ -2297,8 +2297,8 @@ check_inquiry (gfc_expr *e, int not_restricted) if (strcmp (functions[i], name) == 0) break; - if (functions[i] == NULL) - return MATCH_ERROR; + if (functions[i] == NULL) + return MATCH_ERROR; } /* At this point we have an inquiry function with a variable argument. The @@ -2841,6 +2841,18 @@ check_references (gfc_ref* ref, bool (*checker) (gfc_expr*)) return check_references (ref->next, checker); } +/* Return true if ns is a parent of the current ns. */ + +static bool +is_parent_of_current_ns (gfc_namespace *ns) +{ + gfc_namespace *p; + for (p = gfc_current_ns->parent; p; p = p->parent) + if (ns == p) + return true; + + return false; +} /* Verify that an expression is a restricted expression. Like its cousin check_init_expr(), an error message is generated if we @@ -2929,9 +2941,7 @@ check_restricted (gfc_expr *e) || sym->attr.dummy || sym->attr.implied_index || sym->attr.flavor == FL_PARAMETER - || (sym->ns && sym->ns == gfc_current_ns->parent) - || (sym->ns && gfc_current_ns->parent - && sym->ns == gfc_current_ns->parent->parent) + || is_parent_of_current_ns (sym->ns) || (sym->ns->proc_name != NULL && sym->ns->proc_name->attr.flavor == FL_MODULE) || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns))) @@ -3118,19 +3128,22 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) bad_proc = true; /* (ii) The assignment is in the main program; or */ - if (gfc_current_ns->proc_name->attr.is_main_program) + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.is_main_program) bad_proc = true; /* (iii) A module or internal procedure... */ - if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL - || gfc_current_ns->proc_name->attr.proc == PROC_MODULE) + if (gfc_current_ns->proc_name + && (gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL + || gfc_current_ns->proc_name->attr.proc == PROC_MODULE) && gfc_current_ns->parent && (!(gfc_current_ns->parent->proc_name->attr.function || gfc_current_ns->parent->proc_name->attr.subroutine) || gfc_current_ns->parent->proc_name->attr.is_main_program)) { /* ... that is not a function... */ - if (!gfc_current_ns->proc_name->attr.function) + if (gfc_current_ns->proc_name + && !gfc_current_ns->proc_name->attr.function) bad_proc = true; /* ... or is not an entry and has a different name. */ @@ -3234,55 +3247,6 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) } } - /* Warn about type-changing conversions for REAL or COMPLEX constants. - If lvalue and rvalue are mixed REAL and complex, gfc_compare_types - will warn anyway, so there is no need to to so here. */ - - if (rvalue->expr_type == EXPR_CONSTANT && lvalue->ts.type == rvalue->ts.type - && (lvalue->ts.type == BT_REAL || lvalue->ts.type == BT_COMPLEX)) - { - if (lvalue->ts.kind < rvalue->ts.kind && warn_conversion) - { - /* As a special bonus, don't warn about REAL rvalues which are not - changed by the conversion if -Wconversion is specified. */ - if (rvalue->ts.type == BT_REAL && mpfr_number_p (rvalue->value.real)) - { - /* Calculate the difference between the constant and the rounded - value and check it against zero. */ - mpfr_t rv, diff; - gfc_set_model_kind (lvalue->ts.kind); - mpfr_init (rv); - gfc_set_model_kind (rvalue->ts.kind); - mpfr_init (diff); - - mpfr_set (rv, rvalue->value.real, GFC_RND_MODE); - mpfr_sub (diff, rv, rvalue->value.real, GFC_RND_MODE); - - if (!mpfr_zero_p (diff)) - gfc_warning (OPT_Wconversion, - "Change of value in conversion from " - " %qs to %qs at %L", gfc_typename (&rvalue->ts), - gfc_typename (&lvalue->ts), &rvalue->where); - - mpfr_clear (rv); - mpfr_clear (diff); - } - else - gfc_warning (OPT_Wconversion, - "Possible change of value in conversion from %qs " - "to %qs at %L", gfc_typename (&rvalue->ts), - gfc_typename (&lvalue->ts), &rvalue->where); - - } - else if (warn_conversion_extra && lvalue->ts.kind > rvalue->ts.kind) - { - gfc_warning (OPT_Wconversion_extra, - "Conversion from %qs to %qs at %L", - gfc_typename (&rvalue->ts), - gfc_typename (&lvalue->ts), &rvalue->where); - } - } - if (gfc_compare_types (&lvalue->ts, &rvalue->ts)) return true; @@ -4052,6 +4016,7 @@ gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *sym) { gfc_expr *lval; + gfc_array_spec *as; lval = gfc_get_expr (); lval->expr_type = EXPR_VARIABLE; lval->where = sym->declared_at; @@ -4059,10 +4024,10 @@ gfc_lval_expr_from_sym (gfc_symbol *sym) lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name); /* It will always be a full array. */ - lval->rank = sym->as ? sym->as->rank : 0; + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; + lval->rank = as ? as->rank : 0; if (lval->rank) - gfc_add_full_array_ref (lval, sym->ts.type == BT_CLASS ? - CLASS_DATA (sym)->as : sym->as); + gfc_add_full_array_ref (lval, as); return lval; } @@ -4980,7 +4945,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)) { if (context) - gfc_error_1 ("Associate-name '%s' can not appear in a variable" + gfc_error ("Associate-name %qs can not appear in a variable" " definition context (%s) at %L because its target" " at %L can not, either", name, context, &e->where, @@ -5022,12 +4987,12 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (gfc_dep_compare_expr (ec, en) == 0) { if (context) - gfc_error_now_1 ("Elements with the same value " - "at %L and %L in vector " - "subscript in a variable " - "definition context (%s)", - &(ec->where), &(en->where), - context); + gfc_error_now ("Elements with the same value " + "at %L and %L in vector " + "subscript in a variable " + "definition context (%s)", + &(ec->where), &(en->where), + context); return false; } } diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index de9c813bc53..f73bc08aba6 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -28,35 +28,21 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "gfortran.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "options.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" +#include "options.h" #include "flags.h" #include "langhooks.h" #include "langhooks-def.h" #include "timevar.h" #include "tm.h" #include "hard-reg-set.h" -#include "input.h" #include "function.h" -#include "ggc.h" #include "toplev.h" #include "target.h" #include "debug.h" #include "diagnostic.h" /* For errorcount/warningcount */ #include "dumpfile.h" -#include "hash-map.h" -#include "is-a.h" -#include "plugin-api.h" -#include "ipa-ref.h" #include "cgraph.h" #include "cpp.h" #include "trans.h" @@ -97,7 +83,6 @@ static bool global_bindings_p (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_be_parse_file (void); static alias_set_type gfc_get_alias_set (tree); static void gfc_init_ts (void); @@ -124,7 +109,6 @@ static const struct attribute_spec gfc_attribute_table[] = #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_STRUCT #undef LANG_HOOKS_INIT_OPTIONS @@ -158,7 +142,6 @@ static const struct attribute_spec gfc_attribute_table[] = #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_STRUCT gfc_init_options_struct #define LANG_HOOKS_INIT_OPTIONS gfc_init_options @@ -215,31 +198,36 @@ gfc_create_decls (void) /* Build our translation-unit decl. */ current_translation_unit = build_translation_unit_decl (NULL_TREE); + debug_hooks->register_main_translation_unit (current_translation_unit); } static void gfc_be_parse_file (void) { - int errors; - int warnings; - gfc_create_decls (); gfc_parse_file (); gfc_generate_constructors (); - /* Tell the frontend about any errors. */ - gfc_get_errors (&warnings, &errors); - errorcount += errors; - warningcount += warnings; - /* Clear the binding level stack. */ while (!global_bindings_p ()) poplevel (0, 0); + /* Finalize all of the globals. + + Emulated tls lowering needs to see all TLS variables before we + call 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 + here. */ + for (tree decl = getdecls (); decl ; decl = DECL_CHAIN (decl)) + rest_of_decl_compilation (decl, true, true); + /* Switch to the default tree diagnostics here, because there may be diagnostics before gfc_finish(). */ gfc_diagnostics_finish (); + + global_decl_processing (); } @@ -283,32 +271,6 @@ gfc_finish (void) return; } -/* ??? This is something of a hack. - - Emulated tls lowering needs to see all TLS variables before we call - 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 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 (); -} - /* These functions and variables deal with binding contours. We only need these functions for the list of PARM_DECLs, but we leave the functions more general; these are a simplified version of the diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index 446ef196e2c..bc9f6210f4f 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -23,10 +23,11 @@ along with GCC; see the file COPYING3. If not see #include "coretypes.h" #include "gfortran.h" #include "arith.h" -#include "flags.h" +#include "options.h" #include "dependency.h" #include "constructor.h" #include "opts.h" +#include "intrinsic.h" /* Forward declarations. */ @@ -43,7 +44,11 @@ static void doloop_warn (gfc_namespace *); static void optimize_reduction (gfc_namespace *); static int callback_reduction (gfc_expr **, int *, void *); static void realloc_strings (gfc_namespace *); -static gfc_expr *create_var (gfc_expr *); +static gfc_expr *create_var (gfc_expr *, const char *vname=NULL); +static int inline_matmul_assign (gfc_code **, int *, void *); +static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *, + locus *, gfc_namespace *, + char *vname=NULL); /* How deep we are inside an argument list. */ @@ -93,6 +98,19 @@ struct my_struct *evec; static bool in_assoc_list; +/* Counter for temporary variables. */ + +static int var_num = 1; + +/* What sort of matrix we are dealing with when inlining MATMUL. */ + +enum matrix_case { none=0, A2B2, A2B1, A1B2 }; + +/* Keep track of the number of expressions we have inserted so far + using create_var. */ + +int n_vars; + /* Entry point - run all passes for a namespace. */ void @@ -157,7 +175,7 @@ realloc_string_callback (gfc_code **c, int *walk_subtrees, return 0; current_code = c; - n = create_var (expr2); + n = create_var (expr2, "trim"); co->expr2 = n; return 0; } @@ -524,28 +542,13 @@ constant_string_length (gfc_expr *e) } -/* Returns a new expression (a variable) to be used in place of the old one, - with an assignment statement before the current statement to set - the value of the variable. Creates a new BLOCK for the statement if - that hasn't already been done and puts the statement, plus the - newly created variables, in that block. Special cases: If the - expression is constant or a temporary which has already - been created, just copy it. */ +/* Insert a block at the current position unless it has already + been inserted; in this case use the one already there. */ -static gfc_expr* -create_var (gfc_expr * e) +static gfc_namespace* +insert_block () { - char name[GFC_MAX_SYMBOL_LEN +1]; - static int num = 1; - gfc_symtree *symtree; - gfc_symbol *symbol; - gfc_expr *result; - gfc_code *n; gfc_namespace *ns; - int i; - - if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e)) - return gfc_copy_expr (e); /* If the block hasn't already been created, do so. */ if (inserted_block == NULL) @@ -578,7 +581,37 @@ create_var (gfc_expr * e) else ns = inserted_block->ext.block.ns; - sprintf(name, "__var_%d",num++); + return ns; +} + +/* Returns a new expression (a variable) to be used in place of the old one, + with an optional assignment statement before the current statement to set + the value of the variable. Creates a new BLOCK for the statement if that + hasn't already been done and puts the statement, plus the newly created + variables, in that block. Special cases: If the expression is constant or + a temporary which has already been created, just copy it. */ + +static gfc_expr* +create_var (gfc_expr * e, const char *vname) +{ + char name[GFC_MAX_SYMBOL_LEN +1]; + gfc_symtree *symtree; + gfc_symbol *symbol; + gfc_expr *result; + gfc_code *n; + gfc_namespace *ns; + int i; + + if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e)) + return gfc_copy_expr (e); + + ns = insert_block (); + + if (vname) + snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d_%s", var_num++, vname); + else + snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d", var_num++); + if (gfc_get_sym_tree (name, ns, &symtree, false) != 0) gcc_unreachable (); @@ -651,6 +684,7 @@ create_var (gfc_expr * e) result->ref->type = REF_ARRAY; result->ref->u.ar.type = AR_FULL; result->ref->u.ar.where = e->where; + result->ref->u.ar.dimen = e->rank; result->ref->u.ar.as = symbol->ts.type == BT_CLASS ? CLASS_DATA (symbol)->as : symbol->as; if (warn_array_temporaries) @@ -666,6 +700,7 @@ create_var (gfc_expr * e) n->expr1 = gfc_copy_expr (result); n->expr2 = e; *changed_statement = n; + n_vars ++; return result; } @@ -724,7 +759,7 @@ cfe_expr_0 (gfc_expr **e, int *walk_subtrees, if (gfc_dep_compare_functions (*ei, *ej, true) == 0) { if (newvar == NULL) - newvar = create_var (*ei); + newvar = create_var (*ei, "fcn"); if (warn_function_elimination) do_warn_function_elimination (*ej); @@ -931,13 +966,15 @@ convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, /* Don't walk subtrees. */ return 0; } + /* Optimize a namespace, including all contained namespaces. */ static void optimize_namespace (gfc_namespace *ns) { - + gfc_namespace *saved_ns = gfc_current_ns; current_ns = ns; + gfc_current_ns = ns; forall_level = 0; iterator_level = 0; in_assoc_list = false; @@ -947,6 +984,9 @@ optimize_namespace (gfc_namespace *ns) gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL); gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL); gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL); + if (flag_inline_matmul_limit != 0) + gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback, + NULL); /* BLOCKs are handled in the expression walker below. */ for (ns = ns->contained; ns; ns = ns->sibling) @@ -954,6 +994,7 @@ optimize_namespace (gfc_namespace *ns) if (ns->code == NULL || ns->code->op != EXEC_BLOCK) optimize_namespace (ns); } + gfc_current_ns = saved_ns; } /* Handle dependencies for allocatable strings which potentially redefine @@ -968,10 +1009,7 @@ realloc_strings (gfc_namespace *ns) for (ns = ns->contained; ns; ns = ns->sibling) { if (ns->code == NULL || ns->code->op != EXEC_BLOCK) - { - // current_ns = ns; - realloc_strings (ns); - } + realloc_strings (ns); } } @@ -1205,6 +1243,10 @@ combine_array_constructor (gfc_expr *e) if (in_assoc_list) return false; + /* With FORALL, the BLOCKS created by create_var will cause an ICE. */ + if (forall_level > 0) + return false; + op1 = e->value.op.op1; op2 = e->value.op.op2; @@ -1222,7 +1264,7 @@ combine_array_constructor (gfc_expr *e) if (op2->ts.type == BT_CHARACTER) return false; - scalar = create_var (gfc_copy_expr (op2)); + scalar = create_var (gfc_copy_expr (op2), "constr"); oldbase = op1->value.constructor; newbase = NULL; @@ -1841,19 +1883,19 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, && a->expr->symtree->n.sym == do_sym) { if (f->sym->attr.intent == INTENT_OUT) - gfc_error_now_1 ("Variable '%s' at %L set to undefined " - "value inside loop beginning at %L as " - "INTENT(OUT) argument to subroutine '%s'", - do_sym->name, &a->expr->where, - &doloop_list[i]->loc, - co->symtree->n.sym->name); + gfc_error_now ("Variable %qs at %L set to undefined " + "value inside loop beginning at %L as " + "INTENT(OUT) argument to subroutine %qs", + do_sym->name, &a->expr->where, + &doloop_list[i]->loc, + co->symtree->n.sym->name); else if (f->sym->attr.intent == INTENT_INOUT) - gfc_error_now_1 ("Variable '%s' at %L not definable inside " - "loop beginning at %L as INTENT(INOUT) " - "argument to subroutine '%s'", - do_sym->name, &a->expr->where, - &doloop_list[i]->loc, - co->symtree->n.sym->name); + gfc_error_now ("Variable %qs at %L not definable inside " + "loop beginning at %L as INTENT(INOUT) " + "argument to subroutine %qs", + do_sym->name, &a->expr->where, + &doloop_list[i]->loc, + co->symtree->n.sym->name); } } a = a->next; @@ -1913,17 +1955,17 @@ do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, && a->expr->symtree->n.sym == do_sym) { if (f->sym->attr.intent == INTENT_OUT) - gfc_error_now_1 ("Variable '%s' at %L set to undefined value " - "inside loop beginning at %L as INTENT(OUT) " - "argument to function '%s'", do_sym->name, - &a->expr->where, &doloop_list[i]->loc, - expr->symtree->n.sym->name); + gfc_error_now ("Variable %qs at %L set to undefined value " + "inside loop beginning at %L as INTENT(OUT) " + "argument to function %qs", do_sym->name, + &a->expr->where, &doloop_list[i]->loc, + expr->symtree->n.sym->name); else if (f->sym->attr.intent == INTENT_INOUT) - gfc_error_now_1 ("Variable '%s' at %L not definable inside loop" - " beginning at %L as INTENT(INOUT) argument to" - " function '%s'", do_sym->name, - &a->expr->where, &doloop_list[i]->loc, - expr->symtree->n.sym->name); + gfc_error_now ("Variable %qs at %L not definable inside loop" + " beginning at %L as INTENT(INOUT) argument to" + " function %qs", do_sym->name, + &a->expr->where, &doloop_list[i]->loc, + expr->symtree->n.sym->name); } } a = a->next; @@ -1939,6 +1981,1153 @@ doloop_warn (gfc_namespace *ns) gfc_code_walker (&ns->code, doloop_code, do_function, NULL); } +/* This selction deals with inlining calls to MATMUL. */ + +/* Auxiliary function to build and simplify an array inquiry function. + dim is zero-based. */ + +static gfc_expr * +get_array_inq_function (gfc_isym_id id, gfc_expr *e, int dim) +{ + gfc_expr *fcn; + gfc_expr *dim_arg, *kind; + const char *name; + gfc_expr *ec; + + switch (id) + { + case GFC_ISYM_LBOUND: + name = "_gfortran_lbound"; + break; + + case GFC_ISYM_UBOUND: + name = "_gfortran_ubound"; + break; + + case GFC_ISYM_SIZE: + name = "_gfortran_size"; + break; + + default: + gcc_unreachable (); + } + + dim_arg = gfc_get_int_expr (gfc_default_integer_kind, &e->where, dim); + kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where, + gfc_index_integer_kind); + + ec = gfc_copy_expr (e); + fcn = gfc_build_intrinsic_call (current_ns, id, name, e->where, 3, + ec, dim_arg, kind); + gfc_simplify_expr (fcn, 0); + return fcn; +} + +/* Builds a logical expression. */ + +static gfc_expr* +build_logical_expr (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2) +{ + gfc_typespec ts; + gfc_expr *res; + + ts.type = BT_LOGICAL; + ts.kind = gfc_default_logical_kind; + res = gfc_get_expr (); + res->where = e1->where; + res->expr_type = EXPR_OP; + res->value.op.op = op; + res->value.op.op1 = e1; + res->value.op.op2 = e2; + res->ts = ts; + + return res; +} + + +/* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes + compatible typespecs. */ + +static gfc_expr * +get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2) +{ + gfc_expr *res; + + res = gfc_get_expr (); + res->ts = e1->ts; + res->where = e1->where; + res->expr_type = EXPR_OP; + res->value.op.op = op; + res->value.op.op1 = e1; + res->value.op.op2 = e2; + gfc_simplify_expr (res, 0); + return res; +} + +/* Generate the IF statement for a runtime check if we want to do inlining or + not - putting in the code for both branches and putting it into the syntax + tree is the caller's responsibility. For fixed array sizes, this should be + removed by DCE. Only called for rank-two matrices A and B. */ + +static gfc_code * +inline_limit_check (gfc_expr *a, gfc_expr *b, enum matrix_case m_case) +{ + gfc_expr *inline_limit; + gfc_code *if_1, *if_2, *else_2; + gfc_expr *b2, *a2, *a1, *m1, *m2; + gfc_typespec ts; + gfc_expr *cond; + + gcc_assert (m_case == A2B2); + + /* Calculation is done in real to avoid integer overflow. */ + + inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind, + &a->where); + mpfr_set_si (inline_limit->value.real, flag_inline_matmul_limit, + GFC_RND_MODE); + mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, 3, + GFC_RND_MODE); + + a1 = get_array_inq_function (GFC_ISYM_SIZE, a, 1); + a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2); + b2 = get_array_inq_function (GFC_ISYM_SIZE, b, 2); + + gfc_clear_ts (&ts); + ts.type = BT_REAL; + ts.kind = gfc_default_real_kind; + gfc_convert_type_warn (a1, &ts, 2, 0); + gfc_convert_type_warn (a2, &ts, 2, 0); + gfc_convert_type_warn (b2, &ts, 2, 0); + + m1 = get_operand (INTRINSIC_TIMES, a1, a2); + m2 = get_operand (INTRINSIC_TIMES, m1, b2); + + cond = build_logical_expr (INTRINSIC_LE, m2, inline_limit); + gfc_simplify_expr (cond, 0); + + else_2 = XCNEW (gfc_code); + else_2->op = EXEC_IF; + else_2->loc = a->where; + + if_2 = XCNEW (gfc_code); + if_2->op = EXEC_IF; + if_2->expr1 = cond; + if_2->loc = a->where; + if_2->block = else_2; + + if_1 = XCNEW (gfc_code); + if_1->op = EXEC_IF; + if_1->block = if_2; + if_1->loc = a->where; + + return if_1; +} + + +/* Insert code to issue a runtime error if the expressions are not equal. */ + +static gfc_code * +runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg) +{ + gfc_expr *cond; + gfc_code *if_1, *if_2; + gfc_code *c; + gfc_actual_arglist *a1, *a2, *a3; + + gcc_assert (e1->where.lb); + /* Build the call to runtime_error. */ + c = XCNEW (gfc_code); + c->op = EXEC_CALL; + c->loc = e1->where; + + /* Get a null-terminated message string. */ + + a1 = gfc_get_actual_arglist (); + a1->expr = gfc_get_character_expr (gfc_default_character_kind, &e1->where, + msg, strlen(msg)+1); + c->ext.actual = a1; + + /* Pass the value of the first expression. */ + a2 = gfc_get_actual_arglist (); + a2->expr = gfc_copy_expr (e1); + a1->next = a2; + + /* Pass the value of the second expression. */ + a3 = gfc_get_actual_arglist (); + a3->expr = gfc_copy_expr (e2); + a2->next = a3; + + gfc_check_fe_runtime_error (c->ext.actual); + gfc_resolve_fe_runtime_error (c); + + if_2 = XCNEW (gfc_code); + if_2->op = EXEC_IF; + if_2->loc = e1->where; + if_2->next = c; + + if_1 = XCNEW (gfc_code); + if_1->op = EXEC_IF; + if_1->block = if_2; + if_1->loc = e1->where; + + cond = build_logical_expr (INTRINSIC_NE, e1, e2); + gfc_simplify_expr (cond, 0); + if_2->expr1 = cond; + + return if_1; +} + +/* Handle matrix reallocation. Caller is responsible to insert into + the code tree. + + For the two-dimensional case, build + + if (allocated(c)) then + if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then + deallocate(c) + allocate (c(size(a,1), size(b,2))) + end if + else + allocate (c(size(a,1),size(b,2))) + end if + + and for the other cases correspondingly. +*/ + +static gfc_code * +matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b, + enum matrix_case m_case) +{ + + gfc_expr *allocated, *alloc_expr; + gfc_code *if_alloc_1, *if_alloc_2, *if_size_1, *if_size_2; + gfc_code *else_alloc; + gfc_code *deallocate, *allocate1, *allocate_else; + gfc_array_ref *ar; + gfc_expr *cond, *ne1, *ne2; + + if (warn_realloc_lhs) + gfc_warning (OPT_Wrealloc_lhs, + "Code for reallocating the allocatable array at %L will " + "be added", &c->where); + + alloc_expr = gfc_copy_expr (c); + + ar = gfc_find_array_ref (alloc_expr); + gcc_assert (ar && ar->type == AR_FULL); + + /* c comes in as a full ref. Change it into a copy and make it into an + element ref so it has the right form for for ALLOCATE. In the same + switch statement, also generate the size comparison for the secod IF + statement. */ + + ar->type = AR_ELEMENT; + + switch (m_case) + { + case A2B2: + ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1); + ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2); + ne1 = build_logical_expr (INTRINSIC_NE, + get_array_inq_function (GFC_ISYM_SIZE, c, 1), + get_array_inq_function (GFC_ISYM_SIZE, a, 1)); + ne2 = build_logical_expr (INTRINSIC_NE, + get_array_inq_function (GFC_ISYM_SIZE, c, 2), + get_array_inq_function (GFC_ISYM_SIZE, b, 2)); + cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); + break; + + case A2B1: + ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1); + cond = build_logical_expr (INTRINSIC_NE, + get_array_inq_function (GFC_ISYM_SIZE, c, 1), + get_array_inq_function (GFC_ISYM_SIZE, a, 2)); + break; + + case A1B2: + ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, b, 1); + cond = build_logical_expr (INTRINSIC_NE, + get_array_inq_function (GFC_ISYM_SIZE, c, 1), + get_array_inq_function (GFC_ISYM_SIZE, b, 2)); + break; + + default: + gcc_unreachable(); + + } + + gfc_simplify_expr (cond, 0); + + /* We need two identical allocate statements in two + branches of the IF statement. */ + + allocate1 = XCNEW (gfc_code); + allocate1->op = EXEC_ALLOCATE; + allocate1->ext.alloc.list = gfc_get_alloc (); + allocate1->loc = c->where; + allocate1->ext.alloc.list->expr = gfc_copy_expr (alloc_expr); + + allocate_else = XCNEW (gfc_code); + allocate_else->op = EXEC_ALLOCATE; + allocate_else->ext.alloc.list = gfc_get_alloc (); + allocate_else->loc = c->where; + allocate_else->ext.alloc.list->expr = alloc_expr; + + allocated = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ALLOCATED, + "_gfortran_allocated", c->where, + 1, gfc_copy_expr (c)); + + deallocate = XCNEW (gfc_code); + deallocate->op = EXEC_DEALLOCATE; + deallocate->ext.alloc.list = gfc_get_alloc (); + deallocate->ext.alloc.list->expr = gfc_copy_expr (c); + deallocate->next = allocate1; + deallocate->loc = c->where; + + if_size_2 = XCNEW (gfc_code); + if_size_2->op = EXEC_IF; + if_size_2->expr1 = cond; + if_size_2->loc = c->where; + if_size_2->next = deallocate; + + if_size_1 = XCNEW (gfc_code); + if_size_1->op = EXEC_IF; + if_size_1->block = if_size_2; + if_size_1->loc = c->where; + + else_alloc = XCNEW (gfc_code); + else_alloc->op = EXEC_IF; + else_alloc->loc = c->where; + else_alloc->next = allocate_else; + + if_alloc_2 = XCNEW (gfc_code); + if_alloc_2->op = EXEC_IF; + if_alloc_2->expr1 = allocated; + if_alloc_2->loc = c->where; + if_alloc_2->next = if_size_1; + if_alloc_2->block = else_alloc; + + if_alloc_1 = XCNEW (gfc_code); + if_alloc_1->op = EXEC_IF; + if_alloc_1->block = if_alloc_2; + if_alloc_1->loc = c->where; + + return if_alloc_1; +} + +/* Callback function for has_function_or_op. */ + +static int +is_function_or_op (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + if ((*e) == 0) + return 0; + else + return (*e)->expr_type == EXPR_FUNCTION + || (*e)->expr_type == EXPR_OP; +} + +/* Returns true if the expression contains a function. */ + +static bool +has_function_or_op (gfc_expr **e) +{ + if (e == NULL) + return false; + else + return gfc_expr_walker (e, is_function_or_op, NULL); +} + +/* Freeze (assign to a temporary variable) a single expression. */ + +static void +freeze_expr (gfc_expr **ep) +{ + gfc_expr *ne; + if (has_function_or_op (ep)) + { + ne = create_var (*ep, "freeze"); + *ep = ne; + } +} + +/* Go through an expression's references and assign them to temporary + variables if they contain functions. This is usually done prior to + front-end scalarization to avoid multiple invocations of functions. */ + +static void +freeze_references (gfc_expr *e) +{ + gfc_ref *r; + gfc_array_ref *ar; + int i; + + for (r=e->ref; r; r=r->next) + { + if (r->type == REF_SUBSTRING) + { + if (r->u.ss.start != NULL) + freeze_expr (&r->u.ss.start); + + if (r->u.ss.end != NULL) + freeze_expr (&r->u.ss.end); + } + else if (r->type == REF_ARRAY) + { + ar = &r->u.ar; + switch (ar->type) + { + case AR_FULL: + break; + + case AR_SECTION: + for (i=0; i<ar->dimen; i++) + { + if (ar->dimen_type[i] == DIMEN_RANGE) + { + freeze_expr (&ar->start[i]); + freeze_expr (&ar->end[i]); + freeze_expr (&ar->stride[i]); + } + else if (ar->dimen_type[i] == DIMEN_ELEMENT) + { + freeze_expr (&ar->start[i]); + } + } + break; + + case AR_ELEMENT: + for (i=0; i<ar->dimen; i++) + freeze_expr (&ar->start[i]); + break; + + default: + break; + } + } + } +} + +/* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */ + +static gfc_expr * +convert_to_index_kind (gfc_expr *e) +{ + gfc_expr *res; + + gcc_assert (e != NULL); + + res = gfc_copy_expr (e); + + gcc_assert (e->ts.type == BT_INTEGER); + + if (res->ts.kind != gfc_index_integer_kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_INTEGER; + ts.kind = gfc_index_integer_kind; + + gfc_convert_type_warn (e, &ts, 2, 0); + } + + return res; +} + +/* Function to create a DO loop including creation of the + iteration variable. gfc_expr are copied.*/ + +static gfc_code * +create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where, + gfc_namespace *ns, char *vname) +{ + + char name[GFC_MAX_SYMBOL_LEN +1]; + gfc_symtree *symtree; + gfc_symbol *symbol; + gfc_expr *i; + gfc_code *n, *n2; + + /* Create an expression for the iteration variable. */ + if (vname) + sprintf (name, "__var_%d_do_%s", var_num++, vname); + else + sprintf (name, "__var_%d_do", var_num++); + + + if (gfc_get_sym_tree (name, ns, &symtree, false) != 0) + gcc_unreachable (); + + /* Create the loop variable. */ + + symbol = symtree->n.sym; + symbol->ts.type = BT_INTEGER; + symbol->ts.kind = gfc_index_integer_kind; + symbol->attr.flavor = FL_VARIABLE; + symbol->attr.referenced = 1; + symbol->attr.dimension = 0; + symbol->attr.fe_temp = 1; + gfc_commit_symbol (symbol); + + i = gfc_get_expr (); + i->expr_type = EXPR_VARIABLE; + i->ts = symbol->ts; + i->rank = 0; + i->where = *where; + i->symtree = symtree; + + /* ... and the nested DO statements. */ + n = XCNEW (gfc_code); + n->op = EXEC_DO; + n->loc = *where; + n->ext.iterator = gfc_get_iterator (); + n->ext.iterator->var = i; + n->ext.iterator->start = convert_to_index_kind (start); + n->ext.iterator->end = convert_to_index_kind (end); + if (step) + n->ext.iterator->step = convert_to_index_kind (step); + else + n->ext.iterator->step = gfc_get_int_expr (gfc_index_integer_kind, + where, 1); + + n2 = XCNEW (gfc_code); + n2->op = EXEC_DO; + n2->loc = *where; + n2->next = NULL; + n->block = n2; + return n; +} + +/* Get the upper bound of the DO loops for matmul along a dimension. This + is one-based. */ + +static gfc_expr* +get_size_m1 (gfc_expr *e, int dimen) +{ + mpz_t size; + gfc_expr *res; + + if (gfc_array_dimen_size (e, dimen - 1, &size)) + { + res = gfc_get_constant_expr (BT_INTEGER, + gfc_index_integer_kind, &e->where); + mpz_sub_ui (res->value.integer, size, 1); + mpz_clear (size); + } + else + { + res = get_operand (INTRINSIC_MINUS, + get_array_inq_function (GFC_ISYM_SIZE, e, dimen), + gfc_get_int_expr (gfc_index_integer_kind, + &e->where, 1)); + gfc_simplify_expr (res, 0); + } + + return res; +} + +/* Function to return a scalarized expression. It is assumed that indices are + zero based to make generation of DO loops easier. A zero as index will + access the first element along a dimension. Single element references will + be skipped. A NULL as an expression will be replaced by a full reference. + This assumes that the index loops have gfc_index_integer_kind, and that all + references have been frozen. */ + +static gfc_expr* +scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index) +{ + gfc_array_ref *ar; + int i; + int rank; + gfc_expr *e; + int i_index; + bool was_fullref; + + e = gfc_copy_expr(e_in); + + rank = e->rank; + + ar = gfc_find_array_ref (e); + + /* We scalarize count_index variables, reducing the rank by count_index. */ + + e->rank = rank - count_index; + + was_fullref = ar->type == AR_FULL; + + if (e->rank == 0) + ar->type = AR_ELEMENT; + else + ar->type = AR_SECTION; + + /* Loop over the indices. For each index, create the expression + index * stride + lbound(e, dim). */ + + i_index = 0; + for (i=0; i < ar->dimen; i++) + { + if (was_fullref || ar->dimen_type[i] == DIMEN_RANGE) + { + if (index[i_index] != NULL) + { + gfc_expr *lbound, *nindex; + gfc_expr *loopvar; + + loopvar = gfc_copy_expr (index[i_index]); + + if (ar->stride[i]) + { + gfc_expr *tmp; + + tmp = gfc_copy_expr(ar->stride[i]); + if (tmp->ts.kind != gfc_index_integer_kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_INTEGER; + ts.kind = gfc_index_integer_kind; + gfc_convert_type (tmp, &ts, 2); + } + nindex = get_operand (INTRINSIC_TIMES, loopvar, tmp); + } + else + nindex = loopvar; + + /* Calculate the lower bound of the expression. */ + if (ar->start[i]) + { + lbound = gfc_copy_expr (ar->start[i]); + if (lbound->ts.kind != gfc_index_integer_kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_INTEGER; + ts.kind = gfc_index_integer_kind; + gfc_convert_type (lbound, &ts, 2); + + } + } + else + { + gfc_expr *lbound_e; + gfc_ref *ref; + + lbound_e = gfc_copy_expr (e_in); + + for (ref = lbound_e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY + && (ref->u.ar.type == AR_FULL + || ref->u.ar.type == AR_SECTION)) + break; + + if (ref->next) + { + gfc_free_ref_list (ref->next); + ref->next = NULL; + } + + if (!was_fullref) + { + /* Look at full individual sections, like a(:). The first index + is the lbound of a full ref. */ + int j; + gfc_array_ref *ar; + + ar = &ref->u.ar; + ar->type = AR_FULL; + for (j = 0; j < ar->dimen; j++) + { + gfc_free_expr (ar->start[j]); + ar->start[j] = NULL; + gfc_free_expr (ar->end[j]); + ar->end[j] = NULL; + gfc_free_expr (ar->stride[j]); + ar->stride[j] = NULL; + } + + /* We have to get rid of the shape, if there is one. Do + so by freeing it and calling gfc_resolve to rebuild + it, if necessary. */ + + if (lbound_e->shape) + gfc_free_shape (&(lbound_e->shape), lbound_e->rank); + + lbound_e->rank = ar->dimen; + gfc_resolve_expr (lbound_e); + } + lbound = get_array_inq_function (GFC_ISYM_LBOUND, lbound_e, + i + 1); + gfc_free_expr (lbound_e); + } + + ar->dimen_type[i] = DIMEN_ELEMENT; + + gfc_free_expr (ar->start[i]); + ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound); + + gfc_free_expr (ar->end[i]); + ar->end[i] = NULL; + gfc_free_expr (ar->stride[i]); + ar->stride[i] = NULL; + gfc_simplify_expr (ar->start[i], 0); + } + else if (was_fullref) + { + gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented"); + } + i_index ++; + } + } + + return e; +} + +/* Helper function to check for a dimen vector as subscript. */ + +static bool +has_dimen_vector_ref (gfc_expr *e) +{ + gfc_array_ref *ar; + int i; + + ar = gfc_find_array_ref (e); + gcc_assert (ar); + if (ar->type == AR_FULL) + return false; + + for (i=0; i<ar->dimen; i++) + if (ar->dimen_type[i] == DIMEN_VECTOR) + return true; + + return false; +} + +/* If handed an expression of the form + + CONJG(A) + + check if A can be handled by matmul and return if there is an uneven number + of CONJG calls. Return a pointer to the array when everything is OK, NULL + otherwise. The caller has to check for the correct rank. */ + +static gfc_expr* +check_conjg_variable (gfc_expr *e, bool *conjg) +{ + *conjg = false; + + do + { + if (e->expr_type == EXPR_VARIABLE) + { + gcc_assert (e->rank == 1 || e->rank == 2); + return e; + } + else if (e->expr_type == EXPR_FUNCTION) + { + if (e->value.function.isym == NULL) + return NULL; + + if (e->value.function.isym->id == GFC_ISYM_CONJG) + *conjg = !*conjg; + else return NULL; + } + else + return NULL; + + e = e->value.function.actual->expr; + } + while(1); + + return NULL; +} + +/* Inline assignments of the form c = matmul(a,b). + Handle only the cases currently where b and c are rank-two arrays. + + This basically translates the code to + + BLOCK + integer i,j,k + c = 0 + do j=0, size(b,2)-1 + do k=0, size(a, 2)-1 + do i=0, size(a, 1)-1 + c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) = + c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) + + a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) * + b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2)) + end do + end do + end do + END BLOCK + +*/ + +static int +inline_matmul_assign (gfc_code **c, int *walk_subtrees, + void *data ATTRIBUTE_UNUSED) +{ + gfc_code *co = *c; + gfc_expr *expr1, *expr2; + gfc_expr *matrix_a, *matrix_b; + gfc_actual_arglist *a, *b; + gfc_code *do_1, *do_2, *do_3, *assign_zero, *assign_matmul; + gfc_expr *zero_e; + gfc_expr *u1, *u2, *u3; + gfc_expr *list[2]; + gfc_expr *ascalar, *bscalar, *cscalar; + gfc_expr *mult; + gfc_expr *var_1, *var_2, *var_3; + gfc_expr *zero; + gfc_namespace *ns; + gfc_intrinsic_op op_times, op_plus; + enum matrix_case m_case; + int i; + gfc_code *if_limit = NULL; + gfc_code **next_code_point; + bool conjg_a, conjg_b; + + if (co->op != EXEC_ASSIGN) + return 0; + + expr1 = co->expr1; + expr2 = co->expr2; + if (expr2->expr_type != EXPR_FUNCTION + || expr2->value.function.isym == NULL + || expr2->value.function.isym->id != GFC_ISYM_MATMUL) + return 0; + + current_code = c; + inserted_block = NULL; + changed_statement = NULL; + + a = expr2->value.function.actual; + matrix_a = check_conjg_variable (a->expr, &conjg_a); + if (matrix_a == NULL) + return 0; + + b = a->next; + matrix_b = check_conjg_variable (b->expr, &conjg_b); + if (matrix_b == NULL) + return 0; + + if (has_dimen_vector_ref (expr1) || has_dimen_vector_ref (matrix_a) + || has_dimen_vector_ref (matrix_b)) + return 0; + + /* We do not handle data dependencies yet. */ + if (gfc_check_dependency (expr1, matrix_a, true) + || gfc_check_dependency (expr1, matrix_b, true)) + return 0; + + if (matrix_a->rank == 2) + m_case = matrix_b->rank == 1 ? A2B1 : A2B2; + else + m_case = A1B2; + + + ns = insert_block (); + + /* Assign the type of the zero expression for initializing the resulting + array, and the expression (+ and * for real, integer and complex; + .and. and .or for logical. */ + + switch(expr1->ts.type) + { + case BT_INTEGER: + zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0); + op_times = INTRINSIC_TIMES; + op_plus = INTRINSIC_PLUS; + break; + + case BT_LOGICAL: + op_times = INTRINSIC_AND; + op_plus = INTRINSIC_OR; + zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where, + 0); + break; + case BT_REAL: + zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind, + &expr1->where); + mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODE); + op_times = INTRINSIC_TIMES; + op_plus = INTRINSIC_PLUS; + break; + + case BT_COMPLEX: + zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind, + &expr1->where); + mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODE); + op_times = INTRINSIC_TIMES; + op_plus = INTRINSIC_PLUS; + + break; + + default: + gcc_unreachable(); + } + + current_code = &ns->code; + + /* Freeze the references, keeping track of how many temporary variables were + created. */ + n_vars = 0; + freeze_references (matrix_a); + freeze_references (matrix_b); + freeze_references (expr1); + + if (n_vars == 0) + next_code_point = current_code; + else + { + next_code_point = &ns->code; + for (i=0; i<n_vars; i++) + next_code_point = &(*next_code_point)->next; + } + + /* Take care of the inline flag. If the limit check evaluates to a + constant, dead code elimination will eliminate the unneeded branch. */ + + if (m_case == A2B2 && flag_inline_matmul_limit > 0) + { + if_limit = inline_limit_check (matrix_a, matrix_b, m_case); + + /* Insert the original statement into the else branch. */ + if_limit->block->block->next = co; + co->next = NULL; + + /* ... and the new ones go into the original one. */ + *next_code_point = if_limit; + next_code_point = &if_limit->block->next; + } + + assign_zero = XCNEW (gfc_code); + assign_zero->op = EXEC_ASSIGN; + assign_zero->loc = co->loc; + assign_zero->expr1 = gfc_copy_expr (expr1); + assign_zero->expr2 = zero_e; + + /* Handle the reallocation, if needed. */ + if (flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1)) + { + gfc_code *lhs_alloc; + + /* Only need to check a single dimension for the A2B2 case for + bounds checking, the rest will be allocated. */ + + if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS && m_case == A2B2) + { + gfc_code *test; + gfc_expr *a2, *b1; + + a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); + b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); + test = runtime_error_ne (b1, a2, "Dimension of array B incorrect " + "in MATMUL intrinsic: Is %ld, should be %ld"); + *next_code_point = test; + next_code_point = &test->next; + } + + + lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case); + + *next_code_point = lhs_alloc; + next_code_point = &lhs_alloc->next; + + } + else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + { + gfc_code *test; + gfc_expr *a2, *b1, *c1, *c2, *a1, *b2; + + if (m_case == A2B2 || m_case == A2B1) + { + a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); + b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); + test = runtime_error_ne (b1, a2, "Dimension of array B incorrect " + "in MATMUL intrinsic: Is %ld, should be %ld"); + *next_code_point = test; + next_code_point = &test->next; + + c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); + a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); + + if (m_case == A2B2) + test = runtime_error_ne (c1, a1, "Incorrect extent in return array in " + "MATMUL intrinsic for dimension 1: " + "is %ld, should be %ld"); + else if (m_case == A2B1) + test = runtime_error_ne (c1, a1, "Incorrect extent in return array in " + "MATMUL intrinsic: " + "is %ld, should be %ld"); + + + *next_code_point = test; + next_code_point = &test->next; + } + else if (m_case == A1B2) + { + a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); + b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); + test = runtime_error_ne (b1, a1, "Dimension of array B incorrect " + "in MATMUL intrinsic: Is %ld, should be %ld"); + *next_code_point = test; + next_code_point = &test->next; + + c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); + b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); + + test = runtime_error_ne (c1, b2, "Incorrect extent in return array in " + "MATMUL intrinsic: " + "is %ld, should be %ld"); + + *next_code_point = test; + next_code_point = &test->next; + } + + if (m_case == A2B2) + { + c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); + b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); + test = runtime_error_ne (c2, b2, "Incorrect extent in return array in " + "MATMUL intrinsic for dimension 2: is %ld, should be %ld"); + + *next_code_point = test; + next_code_point = &test->next; + } + } + + *next_code_point = assign_zero; + + zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0); + + assign_matmul = XCNEW (gfc_code); + assign_matmul->op = EXEC_ASSIGN; + assign_matmul->loc = co->loc; + + /* Get the bounds for the loops, create them and create the scalarized + expressions. */ + + switch (m_case) + { + case A2B2: + inline_limit_check (matrix_a, matrix_b, m_case); + + u1 = get_size_m1 (matrix_b, 2); + u2 = get_size_m1 (matrix_a, 2); + u3 = get_size_m1 (matrix_a, 1); + + do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); + do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); + do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns); + + do_1->block->next = do_2; + do_2->block->next = do_3; + do_3->block->next = assign_matmul; + + var_1 = do_1->ext.iterator->var; + var_2 = do_2->ext.iterator->var; + var_3 = do_3->ext.iterator->var; + + list[0] = var_3; + list[1] = var_1; + cscalar = scalarized_expr (co->expr1, list, 2); + + list[0] = var_3; + list[1] = var_2; + ascalar = scalarized_expr (matrix_a, list, 2); + + list[0] = var_2; + list[1] = var_1; + bscalar = scalarized_expr (matrix_b, list, 2); + + break; + + case A2B1: + u1 = get_size_m1 (matrix_b, 1); + u2 = get_size_m1 (matrix_a, 1); + + do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); + do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); + + do_1->block->next = do_2; + do_2->block->next = assign_matmul; + + var_1 = do_1->ext.iterator->var; + var_2 = do_2->ext.iterator->var; + + list[0] = var_2; + cscalar = scalarized_expr (co->expr1, list, 1); + + list[0] = var_2; + list[1] = var_1; + ascalar = scalarized_expr (matrix_a, list, 2); + + list[0] = var_1; + bscalar = scalarized_expr (matrix_b, list, 1); + + break; + + case A1B2: + u1 = get_size_m1 (matrix_b, 2); + u2 = get_size_m1 (matrix_a, 1); + + do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); + do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); + + do_1->block->next = do_2; + do_2->block->next = assign_matmul; + + var_1 = do_1->ext.iterator->var; + var_2 = do_2->ext.iterator->var; + + list[0] = var_1; + cscalar = scalarized_expr (co->expr1, list, 1); + + list[0] = var_2; + ascalar = scalarized_expr (matrix_a, list, 1); + + list[0] = var_2; + list[1] = var_1; + bscalar = scalarized_expr (matrix_b, list, 2); + + break; + + default: + gcc_unreachable(); + } + + if (conjg_a) + ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg", + matrix_a->where, 1, ascalar); + + if (conjg_b) + bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg", + matrix_b->where, 1, bscalar); + + /* First loop comes after the zero assignment. */ + assign_zero->next = do_1; + + /* Build the assignment expression in the loop. */ + assign_matmul->expr1 = gfc_copy_expr (cscalar); + + mult = get_operand (op_times, ascalar, bscalar); + assign_matmul->expr2 = get_operand (op_plus, cscalar, mult); + + /* If we don't want to keep the original statement around in + the else branch, we can free it. */ + + if (if_limit == NULL) + gfc_free_statements(co); + else + co->next = NULL; + + gfc_free_expr (zero); + *walk_subtrees = 0; + return 0; +} #define WALK_SUBEXPR(NODE) \ do \ diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 9d09de6c53b..69de5ad7a56 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -50,9 +50,7 @@ not after. #include "intl.h" -#include "input.h" #include "splay-tree.h" -#include "vec.h" /* Major control parameters. */ @@ -203,19 +201,19 @@ typedef enum 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_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, - ST_ERROR_STOP, ST_EXIT, ST_FORALL, ST_FORALL_BLOCK, ST_FORMAT, ST_FUNCTION, - ST_GOTO, ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT, - ST_INQUIRE, ST_INTERFACE, ST_SYNC_ALL, ST_SYNC_MEMORY, ST_SYNC_IMAGES, - ST_PARAMETER, ST_MODULE, ST_MODULE_PROC, ST_NAMELIST, ST_NULLIFY, ST_OPEN, - ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC, ST_READ, ST_RETURN, ST_REWIND, - ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT, - ST_WRITE, ST_ASSIGNMENT, ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, - ST_SIMPLE_IF, ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT, - ST_ENUM, ST_ENUMERATOR, ST_END_ENUM, ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS, + 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_SUBMODULE, + ST_END_PROGRAM, ST_END_SELECT, ST_END_SUBROUTINE, ST_END_WHERE, ST_END_TYPE, + ST_ENTRY, ST_EQUIVALENCE, ST_ERROR_STOP, ST_EXIT, ST_FORALL, ST_FORALL_BLOCK, + ST_FORMAT, ST_FUNCTION, ST_GOTO, ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, + ST_IMPORT, ST_INQUIRE, ST_INTERFACE, ST_SYNC_ALL, ST_SYNC_MEMORY, + ST_SYNC_IMAGES, ST_PARAMETER, ST_MODULE, ST_SUBMODULE, ST_MODULE_PROC, + ST_NAMELIST, ST_NULLIFY, ST_OPEN, ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC, + ST_READ, ST_RETURN, ST_REWIND, ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, + ST_WHERE_BLOCK, ST_WHERE, ST_WAIT, ST_WRITE, ST_ASSIGNMENT, + ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, ST_SIMPLE_IF, + ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT, ST_ENUM, + ST_ENUMERATOR, ST_END_ENUM, ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS, ST_OACC_PARALLEL_LOOP, ST_OACC_END_PARALLEL_LOOP, ST_OACC_PARALLEL, ST_OACC_END_PARALLEL, ST_OACC_KERNELS, ST_OACC_END_KERNELS, ST_OACC_DATA, ST_OACC_END_DATA, ST_OACC_HOST_DATA, ST_OACC_END_HOST_DATA, ST_OACC_LOOP, @@ -419,6 +417,7 @@ enum gfc_isym_id GFC_ISYM_EXPONENT, GFC_ISYM_EXTENDS_TYPE_OF, GFC_ISYM_FDATE, + GFC_ISYM_FE_RUNTIME_ERROR, GFC_ISYM_FGET, GFC_ISYM_FGETC, GFC_ISYM_FLOOR, @@ -752,6 +751,9 @@ typedef struct unsigned data:1, /* Symbol is named in a DATA statement. */ is_protected:1, /* Symbol has been marked as protected. */ use_assoc:1, /* Symbol has been use-associated. */ + used_in_submodule:1, /* Symbol has been use-associated in a + submodule. Needed since these entities must + be set host associated to be compliant. */ 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. */ @@ -780,6 +782,11 @@ typedef struct unsigned sequence:1, elemental:1, pure:1, recursive:1; unsigned unmaskable:1, masked:1, contained:1, mod_proc:1, abstract:1; + /* Set if this is a module function or subroutine. Note that it is an + attribute because it appears as a prefix in the declaration like + PURE, etc.. */ + unsigned module_procedure:1; + /* Set if a (public) symbol [e.g. generic name] exposes this symbol, which is relevant for private module procedures. */ unsigned public_used:1; @@ -1002,6 +1009,7 @@ typedef struct AS_EXPLICIT, but we want to remember that we did this. */ + bool resolved; } gfc_array_spec; @@ -1459,6 +1467,9 @@ typedef struct gfc_symbol unsigned forall_index:1; /* Used to avoid multiple resolutions of a single symbol. */ unsigned resolved:1; + /* Set if this is a module function or subroutine with the + abreviated declaration in a submodule. */ + unsigned abr_modproc_decl:1; int refs; struct gfc_namespace *ns; /* namespace containing this symbol */ @@ -1545,6 +1556,7 @@ gfc_use_rename; typedef struct gfc_use_list { const char *module_name; + const char *submodule_name; bool intrinsic; bool non_intrinsic; bool only_flag; @@ -1907,7 +1919,7 @@ typedef struct gfc_intrinsic_sym gfc_typespec ts; unsigned elemental:1, inquiry:1, transformational:1, pure:1, generic:1, specific:1, actual_ok:1, noreturn:1, conversion:1, - from_module:1; + from_module:1, vararg:1; int standard; @@ -2394,6 +2406,9 @@ typedef struct gfc_code { gfc_typespec ts; gfc_alloc *list; + /* Take the array specification from expr3 to allocate arrays + without an explicit array specification. */ + unsigned arr_spec_from_expr3:1; } alloc; @@ -2643,14 +2658,6 @@ const char * gfc_get_string (const char *, ...) ATTRIBUTE_PRINTF_1; bool gfc_find_sym_in_expr (gfc_symbol *, gfc_expr *); /* error.c */ - -typedef struct gfc_error_buf -{ - int flag; - size_t allocated, index; - char *message; -} gfc_error_buf; - void gfc_error_init_1 (void); void gfc_diagnostics_init (void); void gfc_diagnostics_finish (void); @@ -2658,17 +2665,15 @@ void gfc_buffer_error (bool); const char *gfc_print_wide_char (gfc_char_t); -void gfc_warning_1 (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); bool gfc_warning (int opt, const char *, ...) ATTRIBUTE_GCC_GFC(2,3); -void gfc_warning_now_1 (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); bool gfc_warning_now (int opt, const char *, ...) ATTRIBUTE_GCC_GFC(2,3); +bool gfc_warning_now_at (location_t loc, int opt, const char *gmsgid, ...) + ATTRIBUTE_GCC_GFC(3,4); void gfc_clear_warning (void); void gfc_warning_check (void); -void gfc_error_1 (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); void gfc_error (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); -void gfc_error_now_1 (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); void gfc_error_now (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); void gfc_fatal_error (const char *, ...) ATTRIBUTE_NORETURN ATTRIBUTE_GCC_GFC(1,2); void gfc_internal_error (const char *, ...) ATTRIBUTE_NORETURN ATTRIBUTE_GCC_GFC(1,2); @@ -2677,17 +2682,23 @@ bool gfc_error_check (void); bool gfc_error_flag_test (void); notification gfc_notification_std (int); -bool gfc_notify_std_1 (int, const char *, ...) ATTRIBUTE_GCC_GFC(2,3); bool gfc_notify_std (int, const char *, ...) ATTRIBUTE_GCC_GFC(2,3); /* A general purpose syntax error. */ #define gfc_syntax_error(ST) \ gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST)); -#include "pretty-print.h" /* For output_buffer. */ -void gfc_push_error (output_buffer *, gfc_error_buf *); -void gfc_pop_error (output_buffer *, gfc_error_buf *); -void gfc_free_error (output_buffer *, gfc_error_buf *); +#include "pretty-print.h" /* For output_buffer. */ +struct gfc_error_buffer +{ + bool flag; + output_buffer buffer; + gfc_error_buffer(void) : flag(false), buffer() {} +}; + +void gfc_push_error (gfc_error_buffer *); +void gfc_pop_error (gfc_error_buffer *); +void gfc_free_error (gfc_error_buffer *); void gfc_get_errors (int *, int *); void gfc_errors_to_warnings (bool); @@ -2787,7 +2798,7 @@ bool gfc_add_type (gfc_symbol *, gfc_typespec *, locus *); void gfc_clear_attr (symbol_attribute *); bool gfc_missing_attr (symbol_attribute *, locus *); bool gfc_copy_attr (symbol_attribute *, symbol_attribute *, locus *); - +int gfc_copy_dummy_sym (gfc_symbol **, gfc_symbol *, int); bool gfc_add_component (gfc_symbol *, const char *, gfc_component **); gfc_symbol *gfc_use_derived (gfc_symbol *); gfc_symtree *gfc_use_derived_tree (gfc_symtree *); @@ -3088,6 +3099,10 @@ bool gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *, mpz_t *); void gfc_free_interface (gfc_interface *); int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *); int gfc_compare_types (gfc_typespec *, gfc_typespec *); +bool gfc_check_dummy_characteristics (gfc_symbol *, gfc_symbol *, + bool, char *, int); +bool gfc_check_result_characteristics (gfc_symbol *, gfc_symbol *, + char *, int); int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, const char *, int, int, char *, int, const char *, const char *); void gfc_check_interfaces (gfc_namespace *); @@ -3210,6 +3225,11 @@ bool gfc_is_finalizable (gfc_symbol *, gfc_expr **); && CLASS_DATA (sym) \ && CLASS_DATA (sym)->ts.u.derived \ && CLASS_DATA (sym)->ts.u.derived->attr.unlimited_polymorphic) +#define IS_CLASS_ARRAY(sym) \ + (sym->ts.type == BT_CLASS \ + && CLASS_DATA (sym) \ + && CLASS_DATA (sym)->attr.dimension \ + && !CLASS_DATA (sym)->attr.class_pointer) /* frontend-passes.c */ @@ -3226,4 +3246,8 @@ int gfc_code_walker (gfc_code **, walk_code_fn_t, walk_expr_fn_t, void *); void gfc_convert_mpz_to_signed (mpz_t, int); +/* trans-array.c */ + +bool gfc_is_reallocatable_lhs (gfc_expr *); + #endif /* GCC_GFORTRAN_H */ diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 320eb01809a..2ea26304a24 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -66,7 +66,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "flags.h" +#include "options.h" #include "gfortran.h" #include "match.h" #include "arith.h" @@ -346,8 +346,12 @@ gfc_match_end_interface (void) break; m = MATCH_ERROR; - gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, " - "but got %s", s1, s2); + if (strcmp(s2, "none") == 0) + gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> " + "at %C, ", s1); + else + gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, " + "but got %s", s1, s2); } } @@ -484,13 +488,24 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) if (ts1->type == BT_VOID || ts2->type == BT_VOID) return 1; - if (ts1->type == BT_CLASS - && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic) + /* The _data component is not always present, therefore check for its + presence before assuming, that its derived->attr is available. + When the _data component is not present, then nevertheless the + unlimited_polymorphic flag may be set in the derived type's attr. */ + if (ts1->type == BT_CLASS && ts1->u.derived->components + && ((ts1->u.derived->attr.is_class + && ts1->u.derived->components->ts.u.derived->attr + .unlimited_polymorphic) + || ts1->u.derived->attr.unlimited_polymorphic)) return 1; /* F2003: C717 */ if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED - && ts2->u.derived->components->ts.u.derived->attr.unlimited_polymorphic + && ts2->u.derived->components + && ((ts2->u.derived->attr.is_class + && ts2->u.derived->components->ts.u.derived->attr + .unlimited_polymorphic) + || ts2->u.derived->attr.unlimited_polymorphic) && (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c)) return 1; @@ -1051,9 +1066,10 @@ symbol_rank (gfc_symbol *sym) /* Check if the characteristics of two dummy arguments match, cf. F08:12.3.2. */ -static bool -check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, - bool type_must_agree, char *errmsg, int err_len) +bool +gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, + bool type_must_agree, char *errmsg, + int err_len) { if (s1 == NULL || s2 == NULL) return s1 == s2 ? true : false; @@ -1260,8 +1276,8 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, /* Check if the characteristics of two function results match, cf. F08:12.3.3. */ -static bool -check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2, +bool +gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2, char *errmsg, int err_len) { gfc_symbol *r1, *r2; @@ -1457,8 +1473,8 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, if (s1->attr.function && s2->attr.function) { /* If both are functions, check result characteristics. */ - if (!check_result_characteristics (s1, s2, errmsg, err_len) - || !check_result_characteristics (s2, s1, errmsg, err_len)) + if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len) + || !gfc_check_result_characteristics (s2, s1, errmsg, err_len)) return 0; } @@ -1518,7 +1534,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, if (strict_flag) { /* Check all characteristics. */ - if (!check_dummy_characteristics (f1->sym, f2->sym, true, + if (!gfc_check_dummy_characteristics (f1->sym, f2->sym, true, errmsg, err_len)) return 0; } @@ -1695,6 +1711,7 @@ check_sym_interfaces (gfc_symbol *sym) for (p = sym->generic; p; p = p->next) { if (p->sym->attr.mod_proc + && !p->sym->attr.module_procedure && (p->sym->attr.if_source != IFSRC_DECL || p->sym->attr.procedure)) { @@ -2169,7 +2186,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, gfc_error ("Passing coarray at %L to allocatable, noncoarray, " "INTENT(OUT) dummy argument %qs", &actual->where, formal->name); - return 0; + return 0; } else if (warn_surprising && where && formal->attr.intent != INTENT_IN) gfc_warning (OPT_Wsurprising, @@ -2551,7 +2568,7 @@ static int compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, int ranks_must_agree, int is_elemental, locus *where) { - gfc_actual_arglist **new_arg, *a, *actual, temp; + gfc_actual_arglist **new_arg, *a, *actual; gfc_formal_arglist *f; int i, n, na; unsigned long actual_size, formal_size; @@ -3014,13 +3031,8 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (na != 0) { - temp = *new_arg[0]; - *new_arg[0] = *actual; - *actual = temp; - - a = new_arg[0]; - new_arg[0] = new_arg[na]; - new_arg[na] = a; + std::swap (*new_arg[0], *actual); + std::swap (new_arg[0], new_arg[na]); } for (i = 0; i < n - 1; i++) @@ -4231,8 +4243,8 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) return false; } - if (!check_result_characteristics (proc_target, old_target, err, - sizeof(err))) + if (!gfc_check_result_characteristics (proc_target, old_target, + err, sizeof(err))) { gfc_error ("Result mismatch for the overriding procedure " "%qs at %L: %s", proc->name, &where, err); @@ -4283,7 +4295,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) } check_type = proc_pass_arg != argpos && old_pass_arg != argpos; - if (!check_dummy_characteristics (proc_formal->sym, old_formal->sym, + if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym, check_type, err, sizeof(err))) { gfc_error ("Argument mismatch for the overriding procedure " diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index a958f8ec9d1..a80b16e68b4 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -22,7 +22,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "flags.h" +#include "options.h" #include "gfortran.h" #include "intrinsic.h" @@ -520,6 +520,29 @@ add_sym_1s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, (void *) 0); } +/* Add a symbol to the subroutine ilst where the subroutine takes one + printf-style character argument and a variable number of arguments + to follow. */ + +static void +add_sym_1p (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, + int standard, bool (*check) (gfc_actual_arglist *), + 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; + gfc_resolve_f rf; + + cf.f1m = check; + sf.f1 = simplify; + rf.s1 = resolve; + + add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, intent1, + (void *) 0); +} + /* Add a symbol from the MAX/MIN family of intrinsic functions to the function. MAX et al take 2 or more arguments. */ @@ -1159,6 +1182,17 @@ make_from_module (void) next_sym[-1].from_module = 1; } + +/* Mark the current subroutine as having a variable number of + arguments. */ + +static void +make_vararg (void) +{ + if (sizing == SZ_NOTHING) + next_sym[-1].vararg = 1; +} + /* Set the attr.value of the current procedure. */ static void @@ -3292,6 +3326,17 @@ add_subroutines (void) "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT); make_from_module(); + /* Internal subroutine for emitting a runtime error. */ + + add_sym_1p ("fe_runtime_error", GFC_ISYM_FE_RUNTIME_ERROR, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_fe_runtime_error, NULL, gfc_resolve_fe_runtime_error, + "msg", BT_CHARACTER, dc, REQUIRED, INTENT_IN); + + make_noreturn (); + make_vararg (); + make_from_module (); + /* Coarray collectives. */ add_sym_4s ("co_broadcast", GFC_ISYM_CO_BROADCAST, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2008_TS, @@ -4501,7 +4546,7 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag) init_arglist (isym); - if (!sort_actual (name, &c->ext.actual, isym->formal, &c->loc)) + if (!isym->vararg && !sort_actual (name, &c->ext.actual, isym->formal, &c->loc)) goto fail; if (!do_ts29113_check (isym, c->ext.actual)) @@ -4650,15 +4695,18 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag) /* 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 (warn_conversion && from_ts.kind > ts->kind) - gfc_warning_now (OPT_Wconversion, "Possible change of value in " - "conversion from %s to %s at %L", - gfc_typename (&from_ts), gfc_typename (ts), - &expr->where); - else if (warn_conversion_extra) - gfc_warning_now (OPT_Wconversion_extra, "Conversion from %s to %s " - "at %L", gfc_typename (&from_ts), - gfc_typename (ts), &expr->where); + if (expr->expr_type != EXPR_CONSTANT) + { + if (warn_conversion && from_ts.kind > ts->kind) + gfc_warning_now (OPT_Wconversion, "Possible change of value in " + "conversion from %s to %s at %L", + gfc_typename (&from_ts), gfc_typename (ts), + &expr->where); + else if (warn_conversion_extra) + gfc_warning_now (OPT_Wconversion_extra, "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) @@ -4666,7 +4714,7 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag) { /* Conversion from REAL/COMPLEX to INTEGER or COMPLEX to REAL usually comes with a loss of information, regardless of kinds. */ - if (warn_conversion) + if (warn_conversion && expr->expr_type != EXPR_CONSTANT) gfc_warning_now (OPT_Wconversion, "Possible change of value in " "conversion from %s to %s at %L", gfc_typename (&from_ts), gfc_typename (ts), diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index be7f214dddd..a9f16f52743 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -190,6 +190,7 @@ bool gfc_check_system_clock (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_date_and_time (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_exit (gfc_expr *); bool gfc_check_fdate_sub (gfc_expr *); +bool gfc_check_fe_runtime_error (gfc_actual_arglist *); bool gfc_check_flush (gfc_expr *); bool gfc_check_free (gfc_expr *); bool gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *); @@ -602,6 +603,7 @@ 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_fe_runtime_error (gfc_code *); void gfc_resolve_flush (gfc_code *); void gfc_resolve_free (gfc_code *); void gfc_resolve_fseek_sub (gfc_code *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index c071d46cbc1..803e4c73c03 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -8712,7 +8712,7 @@ Elemental function The return value is of type @code{REAL} or @code{COMPLEX}. The kind type parameter is the same as @var{X}. If @var{X} is @code{COMPLEX}, the imaginary part @math{\omega} is in the range -@math{-\pi \leq \omega \leq \pi}. +@math{-\pi < \omega \leq \pi}. @item @emph{Example}: @smallexample diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 9228c78232f..804d2156cb6 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -119,7 +119,7 @@ by type. Explanations are in the following sections. -fdefault-real-8 -fdollar-ok -ffixed-line-length-@var{n} @gol -ffixed-line-length-none -ffree-form -ffree-line-length-@var{n} @gol -ffree-line-length-none -fimplicit-none -finteger-4-integer-8 @gol --fmax-identifier-length -fmodule-private -fno-fixed-form -fno-range-check @gol +-fmax-identifier-length -fmodule-private -ffixed-form -fno-range-check @gol -fopenacc -fopenmp -freal-4-real-10 -freal-4-real-16 -freal-4-real-8 @gol -freal-8-real-10 -freal-8-real-16 -freal-8-real-4 -std=@var{std} } @@ -178,6 +178,7 @@ and warnings}. -finit-character=@var{n} -finit-integer=@var{n} -finit-local-zero @gol -finit-logical=@var{<true|false>} -finit-real=@var{<zero|inf|-inf|nan|snan>} @gol +-finline-matmul-limit=@var{n} @gol -fmax-array-constructor=@var{n} -fmax-stack-var-size=@var{n} -fno-align-commons @gol -fno-automatic -fno-protect-parens -fno-underscoring @gol @@ -199,7 +200,7 @@ accepted by the compiler: @item -ffree-form @itemx -ffixed-form @opindex @code{ffree-form} -@opindex @code{fno-fixed-form} +@opindex @code{ffixed-form} @cindex options, Fortran dialect @cindex file format, free @cindex file format, fixed @@ -744,7 +745,7 @@ This currently includes @option{-Waliasing}, @option{-Wampersand}, @option{-Wconversion}, @option{-Wsurprising}, @option{-Wc-binding-type}, @option{-Wintrinsics-std}, @option{-Wno-tabs}, @option{-Wintrinsic-shadow}, @option{-Wline-truncation}, @option{-Wtarget-lifetime}, -@option{-Wreal-q-constant} and @option{-Wunused}. +@option{-Winteger-division}, @option{-Wreal-q-constant} and @option{-Wunused}. @item -Waliasing @opindex @code{Waliasing} @@ -843,6 +844,13 @@ check that the declared interfaces are consistent across program units. Warn if a procedure is called that has neither an explicit interface nor has been declared as @code{EXTERNAL}. +@item -Winteger-division +@opindex @code{Winteger-division} +@cindex warnings, integer division +@cindex warnings, division of integers +Warn if a constant integer division truncates it result. +As an example, 3/5 evaluates to 0. + @item -Wintrinsics-std @opindex @code{Wintrinsics-std} @cindex warnings, non-standard intrinsics @@ -1537,6 +1545,22 @@ geometric mean of the dimensions of the argument and result matrices. The default value for @var{n} is 30. +@item -finline-matmul-limit=@var{n} +@opindex @code{finline-matmul-limit} +When front-end optimiztion is active, some calls to the @code{MATMUL} +intrinsic function will be inlined. This may result in code size +increase if the size of the matrix cannot be determined at compile +time, as code for both cases is generated. Setting +@code{-finline-matmul-limit=0} will disable inlining in all cases. +Setting this option with a value of @var{n} will produce inline code +for matrices with size up to @var{n}. If the matrices involved are not +square, the size comparison is performed using the geometric mean of +the dimensions of the argument and result matrices. + +The default value for @var{n} is the value specified for +@code{-fblas-matmul-limit} if this option is specified, or unlimitited +otherwise. + @item -frecursive @opindex @code{frecursive} Allow indirect recursion by forcing all local arrays to be allocated @@ -1632,11 +1656,12 @@ if @option{-ffrontend-optimize} is in effect. @cindex Front-end optimization This option performs front-end optimization, based on manipulating parts the Fortran parse tree. Enabled by default by any @option{-O} -option. Optimizations enabled by this option include elimination of -identical function calls within expressions, removing unnecessary -calls to @code{TRIM} in comparisons and assignments and replacing -@code{TRIM(a)} with @code{a(1:LEN_TRIM(a))}. -It can be deselected by specifying @option{-fno-frontend-optimize}. +option. Optimizations enabled by this option include inlining calls +to @code{MATMUL}, elimination of identical function calls within +expressions, removing unnecessary calls to @code{TRIM} in comparisons +and assignments and replacing @code{TRIM(a)} with +@code{a(1:LEN_TRIM(a))}. It can be deselected by specifying +@option{-fno-frontend-optimize}. @end table @xref{Code Gen Options,,Options for Code Generation Conventions, diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 7ba6b092e98..436c09a1dee 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -21,7 +21,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "flags.h" +#include "options.h" #include "gfortran.h" #include "match.h" #include "parse.h" @@ -385,7 +385,7 @@ format_lex (void) if (c == delim) { - c = next_char (INSTRING_NOWARN); + c = next_char (NONSTRING); if (c == '\0') { @@ -1181,7 +1181,7 @@ check_format_string (gfc_expr *e, bool is_input) } -/************ Fortran 95 I/O statement matchers *************/ +/************ Fortran I/O statement matchers *************/ /* Match a FORMAT statement. This amounts to actually parsing the format descriptors in order to correctly locate the end of the @@ -1242,6 +1242,36 @@ gfc_match_format (void) } +/* Check for a CHARACTER variable. The check for scalar is done in + resolve_tag. */ + +static bool +check_char_variable (gfc_expr *e) +{ + if (e->expr_type != EXPR_VARIABLE || e->ts.type != BT_CHARACTER) + { + gfc_error("IOMSG must be a scalar-default-char-variable at %L", &e->where); + return false; + } + return true; +} + + +static bool +is_char_type (const char *name, gfc_expr *e) +{ + gfc_resolve_expr (e); + + if (e->ts.type != BT_CHARACTER) + { + gfc_error ("%s requires a scalar-default-char-expr at %L", + name, &e->where); + return false; + } + return true; +} + + /* Match an expression I/O tag of some sort. */ static match @@ -1552,12 +1582,16 @@ match_open_element (gfc_open *open) match m; m = match_etag (&tag_e_async, &open->asynchronous); + if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", open->asynchronous)) + return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_etag (&tag_unit, &open->unit); if (m != MATCH_NO) return m; - m = match_out_tag (&tag_iomsg, &open->iomsg); + m = match_etag (&tag_iomsg, &open->iomsg); + if (m == MATCH_YES && !check_char_variable (open->iomsg)) + return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_out_tag (&tag_iostat, &open->iostat); @@ -1870,6 +1904,9 @@ gfc_match_open (void) static const char *access_f2003[] = { "STREAM", NULL }; static const char *access_gnu[] = { "APPEND", NULL }; + if (!is_char_type ("ACCESS", open->access)) + goto cleanup; + if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003, access_gnu, open->access->value.character.string, @@ -1882,6 +1919,9 @@ gfc_match_open (void) { static const char *action[] = { "READ", "WRITE", "READWRITE", NULL }; + if (!is_char_type ("ACTION", open->action)) + goto cleanup; + if (!compare_to_allowed_values ("ACTION", action, NULL, NULL, open->action->value.character.string, "OPEN", warn)) @@ -1895,6 +1935,9 @@ gfc_match_open (void) "not allowed in Fortran 95")) goto cleanup; + if (!is_char_type ("ASYNCHRONOUS", open->asynchronous)) + goto cleanup; + if (open->asynchronous->expr_type == EXPR_CONSTANT) { static const char * asynchronous[] = { "YES", "NO", NULL }; @@ -1913,6 +1956,9 @@ gfc_match_open (void) "not allowed in Fortran 95")) goto cleanup; + if (!is_char_type ("BLANK", open->blank)) + goto cleanup; + if (open->blank->expr_type == EXPR_CONSTANT) { static const char *blank[] = { "ZERO", "NULL", NULL }; @@ -1931,6 +1977,9 @@ gfc_match_open (void) "not allowed in Fortran 95")) goto cleanup; + if (!is_char_type ("DECIMAL", open->decimal)) + goto cleanup; + if (open->decimal->expr_type == EXPR_CONSTANT) { static const char * decimal[] = { "COMMA", "POINT", NULL }; @@ -1949,6 +1998,9 @@ gfc_match_open (void) { static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; + if (!is_char_type ("DELIM", open->delim)) + goto cleanup; + if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, open->delim->value.character.string, "OPEN", warn)) @@ -1962,7 +2014,10 @@ gfc_match_open (void) if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %C " "not allowed in Fortran 95")) goto cleanup; - + + if (!is_char_type ("ENCODING", open->encoding)) + goto cleanup; + if (open->encoding->expr_type == EXPR_CONSTANT) { static const char * encoding[] = { "DEFAULT", "UTF-8", NULL }; @@ -1979,6 +2034,9 @@ gfc_match_open (void) { static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL }; + if (!is_char_type ("FORM", open->form)) + goto cleanup; + if (!compare_to_allowed_values ("FORM", form, NULL, NULL, open->form->value.character.string, "OPEN", warn)) @@ -1990,6 +2048,9 @@ gfc_match_open (void) { static const char *pad[] = { "YES", "NO", NULL }; + if (!is_char_type ("PAD", open->pad)) + goto cleanup; + if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, open->pad->value.character.string, "OPEN", warn)) @@ -2001,6 +2062,9 @@ gfc_match_open (void) { static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL }; + if (!is_char_type ("POSITION", open->position)) + goto cleanup; + if (!compare_to_allowed_values ("POSITION", position, NULL, NULL, open->position->value.character.string, "OPEN", warn)) @@ -2014,6 +2078,9 @@ gfc_match_open (void) "not allowed in Fortran 95")) goto cleanup; + if (!is_char_type ("ROUND", open->round)) + goto cleanup; + if (open->round->expr_type == EXPR_CONSTANT) { static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", @@ -2034,6 +2101,9 @@ gfc_match_open (void) "not allowed in Fortran 95")) goto cleanup; + if (!is_char_type ("SIGN", open->sign)) + goto cleanup; + if (open->sign->expr_type == EXPR_CONSTANT) { static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", @@ -2071,6 +2141,9 @@ gfc_match_open (void) static const char *status[] = { "OLD", "NEW", "SCRATCH", "REPLACE", "UNKNOWN", NULL }; + if (!is_char_type ("STATUS", open->status)) + goto cleanup; + if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, open->status->value.character.string, "OPEN", warn)) @@ -2182,7 +2255,9 @@ match_close_element (gfc_close *close) m = match_etag (&tag_status, &close->status); if (m != MATCH_NO) return m; - m = match_out_tag (&tag_iomsg, &close->iomsg); + m = match_etag (&tag_iomsg, &close->iomsg); + if (m == MATCH_YES && !check_char_variable (close->iomsg)) + return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_out_tag (&tag_iostat, &close->iostat); @@ -2256,6 +2331,9 @@ gfc_match_close (void) { static const char *status[] = { "KEEP", "DELETE", NULL }; + if (!is_char_type ("STATUS", close->status)) + goto cleanup; + if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, close->status->value.character.string, "CLOSE", warn)) @@ -2340,7 +2418,9 @@ match_file_element (gfc_filepos *fp) m = match_etag (&tag_unit, &fp->unit); if (m != MATCH_NO) return m; - m = match_out_tag (&tag_iomsg, &fp->iomsg); + m = match_etag (&tag_iomsg, &fp->iomsg); + if (m == MATCH_YES && !check_char_variable (fp->iomsg)) + return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_out_tag (&tag_iostat, &fp->iostat); @@ -2382,9 +2462,7 @@ match_filepos (gfc_statement st, gfc_exec_op op) if (m == MATCH_NO) { m = gfc_match_expr (&fp->unit); - if (m == MATCH_ERROR) - goto done; - if (m == MATCH_NO) + if (m == MATCH_ERROR || m == MATCH_NO) goto syntax; } @@ -2678,6 +2756,8 @@ match_dt_element (io_kind k, gfc_dt *dt) } m = match_etag (&tag_e_async, &dt->asynchronous); + if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", dt->asynchronous)) + return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_etag (&tag_e_blank, &dt->blank); @@ -2707,9 +2787,12 @@ match_dt_element (io_kind k, gfc_dt *dt) m = match_etag (&tag_spos, &dt->pos); if (m != MATCH_NO) return m; - m = match_out_tag (&tag_iomsg, &dt->iomsg); + m = match_etag (&tag_iomsg, &dt->iomsg); + if (m == MATCH_YES && !check_char_variable (dt->iomsg)) + return MATCH_ERROR; if (m != MATCH_NO) return m; + m = match_out_tag (&tag_iostat, &dt->iostat); if (m != MATCH_NO) return m; @@ -3307,6 +3390,9 @@ if (condition) \ return MATCH_ERROR; } + if (!is_char_type ("ASYNCHRONOUS", dt->asynchronous)) + return MATCH_ERROR; + if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous, NULL, NULL, dt->asynchronous->value.character.string, @@ -3336,6 +3422,9 @@ if (condition) \ { static const char * decimal[] = { "COMMA", "POINT", NULL }; + if (!is_char_type ("DECIMAL", dt->decimal)) + return MATCH_ERROR; + if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, dt->decimal->value.character.string, io_kind_name (k), warn)) @@ -3353,10 +3442,14 @@ if (condition) \ "not allowed in Fortran 95")) return MATCH_ERROR; + if (!is_char_type ("BLANK", dt->blank)) + return MATCH_ERROR; + if (dt->blank->expr_type == EXPR_CONSTANT) { static const char * blank[] = { "NULL", "ZERO", NULL }; + if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, dt->blank->value.character.string, io_kind_name (k), warn)) @@ -3374,6 +3467,9 @@ if (condition) \ "not allowed in Fortran 95")) return MATCH_ERROR; + if (!is_char_type ("PAD", dt->pad)) + return MATCH_ERROR; + if (dt->pad->expr_type == EXPR_CONSTANT) { static const char * pad[] = { "YES", "NO", NULL }; @@ -3395,6 +3491,9 @@ if (condition) \ "not allowed in Fortran 95")) return MATCH_ERROR; + if (!is_char_type ("ROUND", dt->round)) + return MATCH_ERROR; + if (dt->round->expr_type == EXPR_CONSTANT) { static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", @@ -3414,6 +3513,10 @@ if (condition) \ if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C " "not allowed in Fortran 95") == false) return MATCH_ERROR; */ + + if (!is_char_type ("SIGN", dt->sign)) + return MATCH_ERROR; + if (dt->sign->expr_type == EXPR_CONSTANT) { static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", @@ -3440,6 +3543,9 @@ if (condition) \ "not allowed in Fortran 95")) return MATCH_ERROR; + if (!is_char_type ("DELIM", dt->delim)) + return MATCH_ERROR; + if (dt->delim->expr_type == EXPR_CONSTANT) { static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; @@ -3862,7 +3968,9 @@ match_inquire_element (gfc_inquire *inquire) m = match_etag (&tag_unit, &inquire->unit); RETM m = match_etag (&tag_file, &inquire->file); RETM m = match_ltag (&tag_err, &inquire->err); - RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg); + RETM m = match_etag (&tag_iomsg, &inquire->iomsg); + if (m == MATCH_YES && !check_char_variable (inquire->iomsg)) + return MATCH_ERROR; RETM m = match_out_tag (&tag_iostat, &inquire->iostat); RETM m = match_vtag (&tag_exist, &inquire->exist); RETM m = match_vtag (&tag_opened, &inquire->opened); @@ -3884,6 +3992,8 @@ match_inquire_element (gfc_inquire *inquire) RETM m = match_vtag (&tag_write, &inquire->write); RETM m = match_vtag (&tag_readwrite, &inquire->readwrite); RETM m = match_vtag (&tag_s_async, &inquire->asynchronous); + if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", inquire->asynchronous)) + return MATCH_ERROR; RETM m = match_vtag (&tag_s_delim, &inquire->delim); RETM m = match_vtag (&tag_s_decimal, &inquire->decimal); RETM m = match_out_tag (&tag_size, &inquire->size); @@ -4145,7 +4255,9 @@ match_wait_element (gfc_wait *wait) RETM m = match_ltag (&tag_err, &wait->err); RETM m = match_ltag (&tag_end, &wait->eor); RETM m = match_ltag (&tag_eor, &wait->end); - RETM m = match_out_tag (&tag_iomsg, &wait->iomsg); + RETM m = match_etag (&tag_iomsg, &wait->iomsg); + if (m == MATCH_YES && !check_char_variable (wait->iomsg)) + return MATCH_ERROR; RETM m = match_out_tag (&tag_iostat, &wait->iostat); RETM m = match_etag (&tag_id, &wait->id); RETM return MATCH_NO; diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 6fa0994cf23..cf79256b14e 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -29,17 +29,9 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "options.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" +#include "options.h" #include "stringpool.h" #include "gfortran.h" #include "intrinsic.h" @@ -218,6 +210,9 @@ gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string) { f->ts.type = BT_CHARACTER; f->ts.kind = string->ts.kind; + if (string->ts.u.cl) + f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl); + f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind); } @@ -227,6 +222,9 @@ gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string) { f->ts.type = BT_CHARACTER; f->ts.kind = string->ts.kind; + if (string->ts.u.cl) + f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl); + f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind); } @@ -2197,6 +2195,19 @@ gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x) f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind); } +void +gfc_resolve_fe_runtime_error (gfc_code *c) +{ + const char *name; + gfc_actual_arglist *a; + + name = gfc_get_string (PREFIX ("runtime_error")); + + for (a = c->ext.actual->next; a; a = a->next) + a->name = "%VAL"; + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} void gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED) diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index d86376a917c..eab3eddae56 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -249,6 +249,10 @@ Wimplicit-procedure Fortran Warning Var(warn_implicit_procedure) Warn about called procedures not explicitly declared +Winteger-division +Fortran Warning Var(warn_integer_division) LangEnabledBy(Fortran,Wall) +Warn about constant integer divisions with truncated results + Wline-truncation Fortran Warning Var(warn_line_truncation) LangEnabledBy(Fortran,Wall) Init(-1) Warn about truncated source lines @@ -542,6 +546,10 @@ Enum(gfc_init_local_real) String(inf) Value(GFC_INIT_REAL_INF) EnumValue Enum(gfc_init_local_real) String(-inf) Value(GFC_INIT_REAL_NEG_INF) +finline-matmul-limit= +Fortran RejectNegative Joined UInteger Var(flag_inline_matmul_limit) Init(-1) +-finline-matmul-limit=<n> Specify the size of the largest matrix for which matmul will be inlined + fmax-array-constructor= Fortran RejectNegative Joined UInteger Var(flag_max_array_constructor) Init(65535) -fmax-array-constructor=<n> Maximum number of objects in an array constructor diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 8234c277243..523e9b2a7f5 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -21,19 +21,12 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" +#include "options.h" #include "flags.h" #include "gfortran.h" #include "match.h" #include "parse.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" #include "stringpool.h" @@ -110,6 +103,9 @@ gfc_op2string (gfc_intrinsic_op op) case INTRINSIC_PARENTHESES: return "parens"; + case INTRINSIC_NONE: + return "none"; + default: break; } @@ -541,7 +537,10 @@ gfc_match_name (char *buffer) c = gfc_next_ascii_char (); if (!(ISALPHA (c) || (c == '_' && flag_allow_leading_underscore))) { - if (!gfc_error_flag_test () && c != '(') + /* Special cases for unary minus and plus, which allows for a sensible + error message for code of the form 'c = exp(-a*b) )' where an + extra ')' appears at the end of statement. */ + if (!gfc_error_flag_test () && c != '(' && c != '-' && c != '+') gfc_error ("Invalid character in name at %C"); gfc_current_locus = old_loc; return MATCH_NO; @@ -3596,7 +3595,7 @@ alloc_opt_list: /* The next 2 conditionals check C631. */ if (ts.type != BT_UNKNOWN) { - gfc_error_1 ("SOURCE tag at %L conflicts with the typespec at %L", + gfc_error ("SOURCE tag at %L conflicts with the typespec at %L", &tmp->where, &old_locus); goto cleanup; } @@ -3633,7 +3632,7 @@ alloc_opt_list: /* Check F08:C637. */ if (ts.type != BT_UNKNOWN) { - gfc_error_1 ("MOLD tag at %L conflicts with the typespec at %L", + gfc_error ("MOLD tag at %L conflicts with the typespec at %L", &tmp->where, &old_locus); goto cleanup; } @@ -3659,8 +3658,8 @@ alloc_opt_list: /* Check F08:C637. */ if (source && mold) { - gfc_error_1 ("MOLD tag at %L conflicts with SOURCE tag at %L", - &mold->where, &source->where); + gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L", + &mold->where, &source->where); goto cleanup; } @@ -4347,12 +4346,12 @@ gfc_match_common (void) /* If we find an error, just print it and continue, cause it's just semantic, and we can see if there are more errors. */ - gfc_error_now_1 ("Variable '%s' at %L in common block '%s' " - "at %C must be declared with a C " - "interoperable kind since common block " - "'%s' is bind(c)", - sym->name, &(sym->declared_at), t->name, - t->name); + gfc_error_now ("Variable %qs at %L in common block %qs " + "at %C must be declared with a C " + "interoperable kind since common block " + "%qs is bind(c)", + sym->name, &(sym->declared_at), t->name, + t->name); } if (sym->attr.is_bind_c == 1) @@ -4886,8 +4885,7 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) match gfc_match_st_function (void) { - gfc_error_buf old_error_1; - output_buffer old_error; + gfc_error_buffer old_error; gfc_symbol *sym; gfc_expr *expr; @@ -4897,7 +4895,7 @@ gfc_match_st_function (void) if (m != MATCH_YES) return m; - gfc_push_error (&old_error, &old_error_1); + gfc_push_error (&old_error); if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL)) goto undo_error; @@ -4909,7 +4907,7 @@ gfc_match_st_function (void) if (m == MATCH_NO) goto undo_error; - gfc_free_error (&old_error, &old_error_1); + gfc_free_error (&old_error); if (m == MATCH_ERROR) return m; @@ -4928,7 +4926,7 @@ gfc_match_st_function (void) return MATCH_YES; undo_error: - gfc_pop_error (&old_error, &old_error_1); + gfc_pop_error (&old_error); return MATCH_NO; } @@ -5457,7 +5455,10 @@ gfc_match_type_is (void) c = gfc_get_case (); c->where = gfc_current_locus; - if (gfc_match_type_spec (&c->ts) == MATCH_ERROR) + m = gfc_match_type_spec (&c->ts); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) goto cleanup; if (gfc_match_char (')') != MATCH_YES) @@ -5537,7 +5538,10 @@ gfc_match_class_is (void) c = gfc_get_case (); c->where = gfc_current_locus; - if (match_derived_type_spec (&c->ts) == MATCH_ERROR) + m = match_derived_type_spec (&c->ts); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) goto cleanup; if (c->ts.type == BT_DERIVED) diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 96d3ec11f3c..91c9825c94d 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -203,6 +203,7 @@ match gfc_match_generic (void); match gfc_match_function_decl (void); match gfc_match_entry (void); match gfc_match_subroutine (void); +match gfc_match_submod_proc (void); match gfc_match_derived_decl (void); match gfc_match_final_decl (void); @@ -291,6 +292,7 @@ match gfc_match_expr (gfc_expr **); /* module.c. */ match gfc_match_use (void); +match gfc_match_submodule (void); void gfc_use_modules (void); #endif /* GFC_MATCH_H */ diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 1abfc46d7a5..db1d3392811 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -73,22 +73,15 @@ along with GCC; see the file COPYING3. If not see #include "parse.h" /* FIXME */ #include "constructor.h" #include "cpp.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "options.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" +#include "options.h" #include "stringpool.h" #include "scanner.h" #include <zlib.h> #define MODULE_EXTENSION ".mod" +#define SUBMODULE_EXTENSION ".smod" /* Don't put any single quote (') in MOD_VERSION, if you want it to be recognized. */ @@ -198,6 +191,8 @@ static gzFile module_fp; /* The name of the module we're reading (USE'ing) or writing. */ static const char *module_name; +/* The name of the .smod file that the submodule will write to. */ +static const char *submodule_name; static gfc_use_list *module_list; /* If we're reading an intrinsic module, this is its ID. */ @@ -723,6 +718,100 @@ cleanup: } +/* Match a SUBMODULE statement. + + According to F2008:11.2.3.2, "The submodule identifier is the + ordered pair whose first element is the ancestor module name and + whose second element is the submodule name. 'Submodule_name' is + used for the submodule filename and uses '@' as a separator, whilst + the name of the symbol for the module uses '.' as a a separator. + The reasons for these choices are: + (i) To follow another leading brand in the submodule filenames; + (ii) Since '.' is not particularly visible in the filenames; and + (iii) The linker does not permit '@' in mnemonics. */ + +match +gfc_match_submodule (void) +{ + match m; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_use_list *use_list; + + if (!gfc_notify_std (GFC_STD_F2008, "SUBMODULE declaration at %C")) + return MATCH_ERROR; + + gfc_new_block = NULL; + gcc_assert (module_list == NULL); + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + while (1) + { + m = gfc_match (" %n", name); + if (m != MATCH_YES) + goto syntax; + + use_list = gfc_get_use_list (); + use_list->where = gfc_current_locus; + + if (module_list) + { + gfc_use_list *last = module_list; + while (last->next) + last = last->next; + last->next = use_list; + use_list->module_name + = gfc_get_string ("%s.%s", module_list->module_name, name); + use_list->submodule_name + = gfc_get_string ("%s@%s", module_list->module_name, name); + } + else + { + module_list = use_list; + use_list->module_name = gfc_get_string (name); + use_list->submodule_name = use_list->module_name; + } + + if (gfc_match_char (')') == MATCH_YES) + break; + + if (gfc_match_char (':') != MATCH_YES) + goto syntax; + } + + m = gfc_match (" %s%t", &gfc_new_block); + if (m != MATCH_YES) + goto syntax; + + submodule_name = gfc_get_string ("%s@%s", module_list->module_name, + gfc_new_block->name); + + gfc_new_block->name = gfc_get_string ("%s.%s", + module_list->module_name, + gfc_new_block->name); + + if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, + gfc_new_block->name, NULL)) + return MATCH_ERROR; + + /* Just retain the ultimate .(s)mod file for reading, since it + contains all the information in its ancestors. */ + use_list = module_list; + for (; module_list->next; use_list = use_list->next) + { + module_list = use_list->next; + free (use_list); + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in SUBMODULE statement at %C"); + return MATCH_ERROR; +} + + /* Given a name and a number, inst, return the inst name under which to load this symbol. Returns NULL if this symbol shouldn't be loaded. If inst is zero, returns @@ -1894,7 +1983,7 @@ typedef enum 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_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET, - AB_ARRAY_OUTER_DEPENDENCY + AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE } ab_attribute; @@ -1951,6 +2040,7 @@ static const mstring attr_bits[] = minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY), minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET), minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY), + minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE), minit (NULL, -1) }; @@ -2133,6 +2223,8 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits); if (attr->array_outer_dependency) MIO_NAME (ab_attribute) (AB_ARRAY_OUTER_DEPENDENCY, attr_bits); + if (attr->module_procedure) + MIO_NAME (ab_attribute) (AB_MODULE_PROCEDURE, attr_bits); mio_rparen (); @@ -2302,6 +2394,9 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_ARRAY_OUTER_DEPENDENCY: attr->array_outer_dependency =1; break; + case AB_MODULE_PROCEDURE: + attr->module_procedure =1; + break; } } } @@ -4479,8 +4574,8 @@ load_commons (void) static void load_equiv (void) { - gfc_equiv *head, *tail, *end, *eq; - bool unused; + gfc_equiv *head, *tail, *end, *eq, *equiv; + bool duplicate; mio_lparen (); in_load_equiv = true; @@ -4507,23 +4602,19 @@ load_equiv (void) mio_expr (&tail->expr); } - /* Unused equivalence members have a unique name. In addition, it - must be checked that the symbols are from the same module. */ - unused = true; - for (eq = head; eq; eq = eq->eq) + /* Check for duplicate equivalences being loaded from different modules */ + duplicate = false; + for (equiv = gfc_current_ns->equiv; equiv; equiv = equiv->next) { - if (eq->expr->symtree->n.sym->module - && head->expr->symtree->n.sym->module - && strcmp (head->expr->symtree->n.sym->module, - eq->expr->symtree->n.sym->module) == 0 - && !check_unique_name (eq->expr->symtree->name)) + if (equiv->module && head->module + && strcmp (equiv->module, head->module) == 0) { - unused = false; + duplicate = true; break; } } - if (unused) + if (duplicate) { for (eq = head; eq; eq = head) { @@ -5877,7 +5968,16 @@ gfc_dump_module (const char *name, int dump_flag) char *filename, *filename_tmp; uLong crc, crc_old; + module_name = gfc_get_string (name); + + if (gfc_state_stack->state == COMP_SUBMODULE) + { + name = submodule_name; + n = strlen (name) + strlen (SUBMODULE_EXTENSION) + 1; + } + else n = strlen (name) + strlen (MODULE_EXTENSION) + 1; + if (gfc_option.module_dir != NULL) { n += strlen (gfc_option.module_dir); @@ -5890,6 +5990,10 @@ gfc_dump_module (const char *name, int dump_flag) filename = (char *) alloca (n); strcpy (filename, name); } + + if (gfc_state_stack->state == COMP_SUBMODULE) + strcat (filename, SUBMODULE_EXTENSION); + else strcat (filename, MODULE_EXTENSION); /* Name of the temporary file used to write the module. */ @@ -5919,7 +6023,6 @@ gfc_dump_module (const char *name, int dump_flag) /* Write the module itself. */ iomode = IO_OUTPUT; - module_name = gfc_get_string (name); init_pi_tree (); @@ -6650,10 +6753,22 @@ gfc_use_module (gfc_use_list *module) gfc_warning_now (OPT_Wuse_without_only, "USE statement at %C has no ONLY qualifier"); - filename = XALLOCAVEC (char, strlen (module_name) + strlen (MODULE_EXTENSION) - + 1); + if (gfc_state_stack->state == COMP_MODULE + || module->submodule_name == NULL + || strcmp (module_name, module->submodule_name) == 0) + { + filename = XALLOCAVEC (char, strlen (module_name) + + strlen (MODULE_EXTENSION) + 1); strcpy (filename, module_name); strcat (filename, MODULE_EXTENSION); + } + else + { + filename = XALLOCAVEC (char, strlen (module->submodule_name) + + strlen (SUBMODULE_EXTENSION) + 1); + strcpy (filename, module->submodule_name); + strcat (filename, SUBMODULE_EXTENSION); + } /* First, try to find an non-intrinsic module, unless the USE statement specified that the module is intrinsic. */ @@ -6768,8 +6883,10 @@ gfc_use_module (gfc_use_list *module) /* Make sure we're not reading the same module that we may be building. */ for (p = gfc_state_stack; p; p = p->previous) - if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0) - gfc_fatal_error ("Can't USE the same module we're building!"); + if ((p->state == COMP_MODULE || p->state == COMP_SUBMODULE) + && strcmp (p->sym->name, module_name) == 0) + gfc_fatal_error ("Can't USE the same %smodule we're building!", + p->state == COMP_SUBMODULE ? "sub" : ""); init_pi_tree (); init_true_name_tree (); diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 21de6072cc2..3c12d8e67f6 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -21,12 +21,10 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "flags.h" #include "gfortran.h" #include "arith.h" #include "match.h" #include "parse.h" -#include "hash-set.h" #include "diagnostic.h" #include "gomp-constants.h" diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index 1262ccc19aa..e367e157e14 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -21,17 +21,9 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "options.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" +#include "options.h" #include "flags.h" #include "intl.h" #include "opts.h" @@ -115,7 +107,7 @@ gfc_init_options (unsigned int decoded_options_count, enabled by default in Fortran. Ideally, we should express this in .opt, but that is not supported yet. */ if (!global_options_set.x_cpp_warn_missing_include_dirs) - global_options.x_cpp_warn_missing_include_dirs = 1;; + global_options.x_cpp_warn_missing_include_dirs = 1; set_default_std_flags (); @@ -378,6 +370,11 @@ gfc_post_options (const char **pfilename) if (!flag_automatic) flag_max_stack_var_size = 0; + /* If we call BLAS directly, only inline up to the BLAS limit. */ + + if (flag_external_blas && flag_inline_matmul_limit < 0) + flag_inline_matmul_limit = flag_blas_matmul_limit; + /* Optimization implies front end optimization, unless the user specified it directly. */ diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 2c7c554d367..45ad63ff7ee 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -22,7 +22,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include <setjmp.h> #include "coretypes.h" -#include "flags.h" +#include "options.h" #include "gfortran.h" #include "match.h" #include "parse.h" @@ -108,14 +108,13 @@ match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus, static void use_modules (void) { - gfc_error_buf old_error_1; - output_buffer old_error; + gfc_error_buffer old_error; - gfc_push_error (&old_error, &old_error_1); + gfc_push_error (&old_error); gfc_buffer_error (false); gfc_use_modules (); gfc_buffer_error (true); - gfc_pop_error (&old_error, &old_error_1); + gfc_pop_error (&old_error); gfc_commit_symbols (); gfc_warning_check (); gfc_current_ns->old_cl_list = gfc_current_ns->cl_list; @@ -370,6 +369,16 @@ decode_statement (void) gfc_undo_symbols (); gfc_current_locus = old_locus; + if (gfc_match_submod_proc () == MATCH_YES) + { + if (gfc_new_block->attr.subroutine) + return ST_SUBROUTINE; + else if (gfc_new_block->attr.function) + return ST_FUNCTION; + } + gfc_undo_symbols (); + gfc_current_locus = old_locus; + /* 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 @@ -523,6 +532,7 @@ decode_statement (void) match ("sequence", gfc_match_eos, ST_SEQUENCE); match ("stop", gfc_match_stop, ST_STOP); match ("save", gfc_match_save, ST_ATTR_DECL); + match ("submodule", gfc_match_submodule, ST_SUBMODULE); match ("sync all", gfc_match_sync_all, ST_SYNC_ALL); match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); @@ -1535,8 +1545,8 @@ gfc_enclosing_unit (gfc_compile_state * result) for (p = gfc_state_stack; p; p = p->previous) if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE - || p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA - || p->state == COMP_PROGRAM) + || p->state == COMP_MODULE || p->state == COMP_SUBMODULE + || p->state == COMP_BLOCK_DATA || p->state == COMP_PROGRAM) { if (result != NULL) @@ -1661,6 +1671,9 @@ gfc_ascii_statement (gfc_statement st) case ST_END_MODULE: p = "END MODULE"; break; + case ST_END_SUBMODULE: + p = "END SUBMODULE"; + break; case ST_END_PROGRAM: p = "END PROGRAM"; break; @@ -1743,6 +1756,9 @@ gfc_ascii_statement (gfc_statement st) case ST_MODULE: p = "MODULE"; break; + case ST_SUBMODULE: + p = "SUBMODULE"; + break; case ST_PAUSE: p = "PAUSE"; break; @@ -2187,6 +2203,7 @@ accept_statement (gfc_statement st) case ST_FUNCTION: case ST_SUBROUTINE: case ST_MODULE: + case ST_SUBMODULE: gfc_current_ns->proc_name = gfc_new_block; break; @@ -2425,8 +2442,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent) break; default: - gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C", - gfc_ascii_statement (st)); + return false; } /* All is well, record the statement in case we need it next time. */ @@ -2436,7 +2452,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent) order: if (!silent) - gfc_error_1 ("%s statement at %C cannot follow %s statement at %L", + gfc_error ("%s statement at %C cannot follow %s statement at %L", gfc_ascii_statement (st), gfc_ascii_statement (p->last_statement), &p->where); @@ -2813,7 +2829,7 @@ endType: "subcomponent exists)", c->name, &c->loc, sym->name); if (sym->attr.lock_comp && coarray && !lock_type) - gfc_error_1 ("Noncoarray component %s at %L of type LOCK_TYPE or with " + gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with " "subcomponent of type LOCK_TYPE must have a codimension or " "be a subcomponent of a coarray. (Variables of type %s may " "not have a codimension as %s at %L has a codimension or a " @@ -2933,6 +2949,10 @@ loop: gfc_free_namespace (gfc_current_ns); goto loop; } + /* F2008 C1210 forbids the IMPORT statement in module procedure + interface bodies and the flag is set to import symbols. */ + if (gfc_new_block->attr.module_procedure) + gfc_current_ns->has_import_set = 1; break; case ST_PROCEDURE: @@ -3282,7 +3302,8 @@ declSt: break; case ST_STATEMENT_FUNCTION: - if (gfc_current_state () == COMP_MODULE) + if (gfc_current_state () == COMP_MODULE + || gfc_current_state () == COMP_SUBMODULE) { unexpected_statement (st); break; @@ -3528,7 +3549,7 @@ parse_if_block (void) case ST_ELSEIF: if (seen_else) { - gfc_error_1 ("ELSE IF statement at %C cannot follow ELSE " + gfc_error ("ELSE IF statement at %C cannot follow ELSE " "statement at %L", &else_locus); reject_statement (); @@ -3752,8 +3773,8 @@ gfc_check_do_variable (gfc_symtree *st) for (s=gfc_state_stack; s; s = s->previous) if (s->do_variable == st) { - gfc_error_now_1 ("Variable '%s' at %C cannot be redefined inside " - "loop beginning at %L", st->name, &s->head->loc); + gfc_error_now ("Variable %qs at %C cannot be redefined inside " + "loop beginning at %L", st->name, &s->head->loc); return 1; } @@ -3960,6 +3981,8 @@ parse_associate (void) for (a = new_st.ext.block.assoc; a; a = a->next) { gfc_symbol* sym; + gfc_ref *ref; + gfc_array_ref *array_ref; if (gfc_get_sym_tree (a->name, NULL, &a->st, false)) gcc_unreachable (); @@ -3976,6 +3999,84 @@ parse_associate (void) for parsing component references on the associate-name in case of association to a derived-type. */ sym->ts = a->target->ts; + + /* Check if the target expression is array valued. This can not always + be done by looking at target.rank, because that might not have been + set yet. Therefore traverse the chain of refs, looking for the last + array ref and evaluate that. */ + array_ref = NULL; + for (ref = a->target->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY) + array_ref = &ref->u.ar; + if (array_ref || a->target->rank) + { + gfc_array_spec *as; + int dim, rank = 0; + if (array_ref) + { + /* Count the dimension, that have a non-scalar extend. */ + for (dim = 0; dim < array_ref->dimen; ++dim) + if (array_ref->dimen_type[dim] != DIMEN_ELEMENT + && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN + && array_ref->end[dim] == NULL + && array_ref->start[dim] != NULL)) + ++rank; + } + else + rank = a->target->rank; + /* When the rank is greater than zero then sym will be an array. */ + if (sym->ts.type == BT_CLASS) + { + if ((!CLASS_DATA (sym)->as && rank != 0) + || (CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->rank != rank)) + { + /* Don't just (re-)set the attr and as in the sym.ts, + because this modifies the target's attr and as. Copy the + data and do a build_class_symbol. */ + symbol_attribute attr = CLASS_DATA (a->target)->attr; + int corank = gfc_get_corank (a->target); + gfc_typespec type; + + if (rank || corank) + { + as = gfc_get_array_spec (); + as->type = AS_DEFERRED; + as->rank = rank; + as->corank = corank; + attr.dimension = rank ? 1 : 0; + attr.codimension = corank ? 1 : 0; + } + else + { + as = NULL; + attr.dimension = attr.codimension = 0; + } + attr.class_ok = 0; + type = CLASS_DATA (sym)->ts; + if (!gfc_build_class_symbol (&type, + &attr, &as)) + gcc_unreachable (); + sym->ts = type; + sym->ts.type = BT_CLASS; + sym->attr.class_ok = 1; + } + else + sym->attr.class_ok = 1; + } + else if ((!sym->as && rank != 0) + || (sym->as && sym->as->rank != rank)) + { + as = gfc_get_array_spec (); + as->type = AS_DEFERRED; + as->rank = rank; + as->corank = gfc_get_corank (a->target); + sym->as = as; + sym->attr.dimension = 1; + if (as->corank) + sym->attr.codimension = 1; + } + } } accept_statement (ST_ASSOCIATE); @@ -4283,7 +4384,7 @@ parse_oacc_structured_block (gfc_statement acc_st) unexpected_eof (); else if (st != acc_end_st) gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st)); - reject_statement (); + reject_statement (); } while (st != acc_end_st); @@ -4905,6 +5006,7 @@ parse_contained (int module) /* These statements are associated with the end of the host unit. */ case ST_END_FUNCTION: case ST_END_MODULE: + case ST_END_SUBMODULE: case ST_END_PROGRAM: case ST_END_SUBROUTINE: accept_statement (st); @@ -4921,7 +5023,8 @@ parse_contained (int module) } } while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE - && st != ST_END_MODULE && st != ST_END_PROGRAM); + && st != ST_END_MODULE && st != ST_END_SUBMODULE + && st != ST_END_PROGRAM); /* The first namespace in the list is guaranteed to not have anything (worthwhile) in it. */ @@ -4941,6 +5044,35 @@ parse_contained (int module) } +/* The result variable in a MODULE PROCEDURE needs to be created and + its characteristics copied from the interface since it is neither + declared in the procedure declaration nor in the specification + part. */ + +static void +get_modproc_result (void) +{ + gfc_symbol *proc; + if (gfc_state_stack->previous + && gfc_state_stack->previous->state == COMP_CONTAINS + && gfc_state_stack->previous->previous->state == COMP_SUBMODULE) + { + proc = gfc_current_ns->proc_name ? gfc_current_ns->proc_name : NULL; + if (proc != NULL + && proc->attr.function + && proc->ts.interface + && proc->ts.interface->result + && proc->ts.interface->result != proc->ts.interface) + { + gfc_copy_dummy_sym (&proc->result, proc->ts.interface->result, 1); + gfc_set_sym_referenced (proc->result); + proc->result->attr.if_source = IFSRC_DECL; + gfc_commit_symbol (proc->result); + } + } +} + + /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */ static void @@ -4949,6 +5081,11 @@ parse_progunit (gfc_statement st) gfc_state_data *p; int n; + if (gfc_new_block + && gfc_new_block->abr_modproc_decl + && gfc_new_block->attr.function) + get_modproc_result (); + st = parse_spec (st); switch (st) { @@ -5008,7 +5145,8 @@ contains: if (p->state == COMP_CONTAINS) n++; - if (gfc_find_state (COMP_MODULE) == true) + if (gfc_find_state (COMP_MODULE) == true + || gfc_find_state (COMP_SUBMODULE) == true) n--; if (n > 0) @@ -5071,10 +5209,10 @@ gfc_global_used (gfc_gsymbol *sym, locus *where) } if (sym->binding_label) - gfc_error_1 ("Global binding name '%s' at %L is already being used as a %s " + gfc_error ("Global binding name %qs at %L is already being used as a %s " "at %L", sym->binding_label, where, name, &sym->where); else - gfc_error_1 ("Global name '%s' at %L is already being used as a %s at %L", + gfc_error ("Global name %qs at %L is already being used as a %s at %L", sym->name, where, name, &sym->where); } @@ -5129,6 +5267,36 @@ parse_block_data (void) } +/* Following the association of the ancestor (sub)module symbols, they + must be set host rather than use associated and all must be public. + They are flagged up by 'used_in_submodule' so that they can be set + DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the + linker chokes on multiple symbol definitions. */ + +static void +set_syms_host_assoc (gfc_symbol *sym) +{ + gfc_component *c; + + if (sym == NULL) + return; + + if (sym->attr.module_procedure) + sym->attr.external = 0; + +/* sym->attr.access = ACCESS_PUBLIC; */ + + sym->attr.use_assoc = 0; + sym->attr.host_assoc = 1; + sym->attr.used_in_submodule =1; + + if (sym->attr.flavor == FL_DERIVED) + { + for (c = sym->components; c; c = c->next) + c->attr.access = ACCESS_PUBLIC; + } +} + /* Parse a module subprogram. */ static void @@ -5148,6 +5316,15 @@ parse_module (void) s->defined = 1; } + /* Something is nulling the module_list after this point. This is good + since it allows us to 'USE' the parent modules that the submodule + inherits and to set (most) of the symbols as host associated. */ + if (gfc_current_state () == COMP_SUBMODULE) + { + use_modules (); + gfc_traverse_ns (gfc_current_ns, set_syms_host_assoc); + } + st = parse_spec (ST_NONE); error = false; @@ -5162,6 +5339,7 @@ loop: break; case ST_END_MODULE: + case ST_END_SUBMODULE: accept_statement (st); break; @@ -5457,6 +5635,14 @@ loop: parse_module (); break; + case ST_SUBMODULE: + push_state (&s, COMP_SUBMODULE, gfc_new_block); + accept_statement (st); + + gfc_get_errors (NULL, &errors_before); + parse_module (); + break; + /* Anything else starts a nameless main program block. */ default: if (seen_program) @@ -5481,7 +5667,7 @@ loop: gfc_dump_parse_tree (gfc_current_ns, stdout); gfc_get_errors (NULL, &errors); - if (s.state == COMP_MODULE) + if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE) { gfc_dump_module (s.sym->name, errors_before == errors); gfc_current_ns->derived_types = gfc_derived_types; @@ -5544,7 +5730,7 @@ duplicate_main: /* If we see a duplicate main program, shut down. If the second instance is an implied main program, i.e. data decls or executable statements, we're in for lots of errors. */ - gfc_error_1 ("Two main PROGRAMs at %L and %C", &prog_locus); + gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus); reject_statement (); gfc_done_2 (); return true; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 8a1613f5322..dcac98aac69 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -25,9 +25,9 @@ along with GCC; see the file COPYING3. If not see /* 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_ASSOCIATE, COMP_IF, + COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBMODULE, COMP_SUBROUTINE, + COMP_FUNCTION, COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, + COMP_DERIVED_CONTAINS, 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, COMP_DO_CONCURRENT } diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index e9ced7e6f71..c8c65816a33 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -21,7 +21,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "flags.h" +#include "options.h" #include "gfortran.h" #include "arith.h" #include "match.h" @@ -736,6 +736,58 @@ done: gfc_internal_error ("gfc_range_check() returned bad value"); } + /* Warn about trailing digits which suggest the user added too many + trailing digits, which may cause the appearance of higher pecision + than the kind kan support. + + This is done by replacing the rightmost non-zero digit with zero + and comparing with the original value. If these are equal, we + assume the user supplied more digits than intended (or forgot to + convert to the correct kind). + */ + + if (warn_conversion_extra) + { + mpfr_t r; + char *c, *p; + bool did_break; + + c = strchr (buffer, 'e'); + if (c == NULL) + c = buffer + strlen(buffer); + + did_break = false; + for (p = c - 1; p >= buffer; p--) + { + if (*p == '.') + continue; + + if (*p != '0') + { + *p = '0'; + did_break = true; + break; + } + } + + if (did_break) + { + mpfr_init (r); + mpfr_set_str (r, buffer, 10, GFC_RND_MODE); + if (negate) + mpfr_neg (r, r, GFC_RND_MODE); + + mpfr_sub (r, r, e->value.real, GFC_RND_MODE); + + if (mpfr_cmp_ui (r, 0) == 0) + gfc_warning (OPT_Wconversion_extra, "Non-significant digits " + "in %qs number at %C, maybe incorrect KIND", + gfc_typename (&e->ts)); + + mpfr_clear (r); + } + } + *result = e; return MATCH_YES; @@ -1202,6 +1254,9 @@ match_sym_complex_part (gfc_expr **result) return MATCH_ERROR; } + if (!sym->value) + goto error; + if (!gfc_numeric_ts (&sym->value->ts)) { gfc_error ("Numeric PARAMETER required in complex constant at %C"); @@ -1274,8 +1329,7 @@ static match match_complex_constant (gfc_expr **result) { gfc_expr *e, *real, *imag; - gfc_error_buf old_error_1; - output_buffer old_error; + gfc_error_buffer old_error; gfc_typespec target; locus old_loc; int kind; @@ -1288,18 +1342,18 @@ match_complex_constant (gfc_expr **result) if (m != MATCH_YES) return m; - gfc_push_error (&old_error, &old_error_1); + gfc_push_error (&old_error); m = match_complex_part (&real); if (m == MATCH_NO) { - gfc_free_error (&old_error, &old_error_1); + gfc_free_error (&old_error); goto cleanup; } if (gfc_match_char (',') == MATCH_NO) { - gfc_pop_error (&old_error, &old_error_1); + gfc_pop_error (&old_error); m = MATCH_NO; goto cleanup; } @@ -1311,10 +1365,10 @@ match_complex_constant (gfc_expr **result) if (m == MATCH_ERROR) { - gfc_free_error (&old_error, &old_error_1); + gfc_free_error (&old_error); goto cleanup; } - gfc_pop_error (&old_error, &old_error_1); + gfc_pop_error (&old_error); m = match_complex_part (&imag); if (m == MATCH_NO) @@ -1860,7 +1914,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (sym->assoc && gfc_peek_ascii_char () == '(' && !(sym->assoc->dangling && sym->assoc->st && sym->assoc->st->n.sym - && sym->assoc->st->n.sym->attr.dimension == 0)) + && sym->assoc->st->n.sym->attr.dimension == 0) + && sym->ts.type != BT_CLASS) sym->attr.dimension = 1; if ((equiv_flag && gfc_peek_ascii_char () == '(') @@ -2909,7 +2964,8 @@ gfc_match_rvalue (gfc_expr **result) st = gfc_enclosing_unit (NULL); - if (st != NULL && st->state == COMP_FUNCTION + if (st != NULL + && st->state == COMP_FUNCTION && st->sym == sym && !sym->attr.recursive) { @@ -3213,6 +3269,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag) of keywords, such as 'end', being turned into variables by failed matching to assignments for, e.g., END INTERFACE. */ if (gfc_current_state () == COMP_MODULE + || gfc_current_state () == COMP_SUBMODULE || gfc_current_state () == COMP_INTERFACE || gfc_current_state () == COMP_CONTAINS) host_flag = 0; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 316b413d756..641a3bdaa9a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -21,7 +21,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "flags.h" +#include "options.h" #include "gfortran.h" #include "obstack.h" #include "bitmap.h" @@ -418,7 +418,7 @@ resolve_formal_arglist (gfc_symbol *proc) /* F08:C1278a. */ if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT) { - gfc_error ("INTENT(OUT) argument '%s' of pure procedure %qs at %L" + gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L" " may not be polymorphic", sym->name, proc->name, &sym->declared_at); continue; @@ -993,7 +993,7 @@ resolve_common_blocks (gfc_symtree *common_root) || (!common_root->n.common->binding_label && gsym->binding_label))) { - gfc_error_1 ("In Fortran 2003 COMMON '%s' block at %L is a global " + gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global " "identifier and must thus have the same binding name " "as the same-named COMMON block at %L: %s vs %s", common_root->n.common->name, &common_root->n.common->where, @@ -1007,7 +1007,7 @@ resolve_common_blocks (gfc_symtree *common_root) if (gsym && gsym->type != GSYM_COMMON && !common_root->n.common->binding_label) { - gfc_error_1 ("COMMON block '%s' at %L uses the same global identifier " + gfc_error ("COMMON block %qs at %L uses the same global identifier " "as entity at %L", common_root->n.common->name, &common_root->n.common->where, &gsym->where); @@ -1015,7 +1015,7 @@ resolve_common_blocks (gfc_symtree *common_root) } if (gsym && gsym->type != GSYM_COMMON) { - gfc_error_1 ("Fortran 2008: COMMON block '%s' with binding label at " + gfc_error ("Fortran 2008: COMMON block %qs with binding label at " "%L sharing the identifier with global non-COMMON-block " "entity at %L", common_root->n.common->name, &common_root->n.common->where, &gsym->where); @@ -1037,7 +1037,7 @@ resolve_common_blocks (gfc_symtree *common_root) common_root->n.common->binding_label); if (gsym && gsym->type != GSYM_COMMON) { - gfc_error_1 ("COMMON block at %L with binding label %s uses the same " + gfc_error ("COMMON block at %L with binding label %s uses the same " "global identifier as entity at %L", &common_root->n.common->where, common_root->n.common->binding_label, &gsym->where); @@ -1058,7 +1058,7 @@ resolve_common_blocks (gfc_symtree *common_root) return; if (sym->attr.flavor == FL_PARAMETER) - gfc_error_1 ("COMMON block '%s' at %L is used as PARAMETER at %L", + gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L", sym->name, &common_root->n.common->where, &sym->declared_at); if (sym->attr.external) @@ -1981,7 +1981,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, } comp = gfc_get_proc_ptr_comp(e); - if (comp && comp->attr.elemental) + if (e->expr_type == EXPR_VARIABLE + && comp && comp->attr.elemental) { gfc_error ("ELEMENTAL procedure pointer component %qs is not " "allowed as an actual argument at %L", comp->name, @@ -2383,14 +2384,11 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, if (!gsym->ns->resolved) { gfc_dt_list *old_dt_list; - struct gfc_omp_saved_state old_omp_state; /* Stash away derived types so that the backend_decls do not get mixed up. */ old_dt_list = gfc_derived_types; gfc_derived_types = NULL; - /* And stash away openmp state. */ - gfc_omp_save_and_clear_state (&old_omp_state); gfc_resolve (gsym->ns); @@ -2400,8 +2398,6 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, /* Restore the derived types of this namespace. */ gfc_derived_types = old_dt_list; - /* And openmp state. */ - gfc_omp_restore_state (&old_omp_state); } /* Make sure that translation for the gsymbol occurs before @@ -3368,7 +3364,7 @@ resolve_call (gfc_code *c) if (csym && csym->ts.type != BT_UNKNOWN) { - gfc_error_1 ("'%s' at %L has a type, which is not consistent with " + gfc_error ("%qs at %L has a type, which is not consistent with " "the CALL at %L", csym->name, &csym->declared_at, &c->loc); return false; } @@ -3494,8 +3490,8 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2) { if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0) { - gfc_error_1 ("Shapes for operands at %L and %L are not conformable", - &op1->where, &op2->where); + gfc_error ("Shapes for operands at %L and %L are not conformable", + &op1->where, &op2->where); t = false; break; } @@ -4973,6 +4969,30 @@ resolve_variable (gfc_expr *e) return false; } + /* For variables that are used in an associate (target => object) where + the object's basetype is array valued while the target is scalar, + the ts' type of the component refs is still array valued, which + can't be translated that way. */ + if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS + && sym->assoc->target->ts.type == BT_CLASS + && CLASS_DATA (sym->assoc->target)->as) + { + gfc_ref *ref = e->ref; + while (ref) + { + switch (ref->type) + { + case REF_COMPONENT: + ref->u.c.sym = sym->ts.u.derived; + /* Stop the loop. */ + ref = NULL; + break; + default: + ref = ref->next; + break; + } + } + } /* 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. @@ -4998,6 +5018,49 @@ resolve_variable (gfc_expr *e) e->ref->u.ar.dimen = 0; } + /* Like above, but for class types, where the checking whether an array + ref is present is more complicated. Furthermore make sure not to add + the full array ref to _vptr or _len refs. */ + if (sym->assoc && sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.dimension + && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype)) + { + gfc_ref *ref, *newref; + + newref = gfc_get_ref (); + newref->type = REF_ARRAY; + newref->u.ar.type = AR_FULL; + newref->u.ar.dimen = 0; + /* Because this is an associate var and the first ref either is a ref to + the _data component or not, no traversal of the ref chain is + needed. The array ref needs to be inserted after the _data ref, + or when that is not present, which may happend for polymorphic + types, then at the first position. */ + ref = e->ref; + if (!ref) + e->ref = newref; + else if (ref->type == REF_COMPONENT + && strcmp ("_data", ref->u.c.component->name) == 0) + { + if (!ref->next || ref->next->type != REF_ARRAY) + { + newref->next = ref->next; + ref->next = newref; + } + else + /* Array ref present already. */ + gfc_free_ref_list (newref); + } + else if (ref->type == REF_ARRAY) + /* Array ref present already. */ + gfc_free_ref_list (newref); + else + { + newref->next = ref; + e->ref = newref; + } + } + if (e->ref && !resolve_ref (e)) return false; @@ -6785,7 +6848,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) if (mpz_cmp (e1->shape[i], s) != 0) { - gfc_error_1 ("Source-expr at %L and allocate-object at %L must " + gfc_error ("Source-expr at %L and allocate-object at %L must " "have the same shape", &e1->where, &e2->where); mpz_clear (s); return false; @@ -6804,7 +6867,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) have a trailing array reference that gives the size of the array. */ static bool -resolve_allocate_expr (gfc_expr *e, gfc_code *code) +resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) { int i, pointer, allocatable, dimension, is_abstract; int codimension; @@ -6943,8 +7006,8 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) /* Check F03:C631. */ if (!gfc_type_compatible (&e->ts, &code->expr3->ts)) { - gfc_error_1 ("Type of entity at %L is type incompatible with " - "source-expr at %L", &e->where, &code->expr3->where); + gfc_error ("Type of entity at %L is type incompatible with " + "source-expr at %L", &e->where, &code->expr3->where); goto failure; } @@ -6955,9 +7018,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) /* Check F03:C633. */ if (code->expr3->ts.kind != e->ts.kind && !unlimited) { - gfc_error_1 ("The allocate-object at %L and the source-expr at %L " - "shall have the same kind type parameter", - &e->where, &code->expr3->where); + 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); goto failure; } @@ -6969,7 +7032,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) && code->expr3->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))) { - gfc_error_1 ("The source-expr at %L shall neither be of type " + gfc_error ("The source-expr at %L shall neither be of type " "LOCK_TYPE nor have a LOCK_TYPE component if " "allocate-object at %L is a coarray", &code->expr3->where, &e->where); @@ -7103,13 +7166,24 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) if (!ref2 || 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); - goto failure; + /* F08:C633. */ + if (code->expr3) + { + if (!gfc_notify_std (GFC_STD_F2008, "Array specification required " + "in ALLOCATE statement at %L", &e->where)) + goto failure; + *array_alloc_wo_spec = true; + } + else + { + gfc_error ("Array specification required in ALLOCATE statement " + "at %L", &e->where); + goto failure; + } } /* Make sure that the array section reference makes sense in the - context of an ALLOCATE specification. */ + context of an ALLOCATE specification. */ ar = &ref2->u.ar; @@ -7124,7 +7198,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) for (i = 0; i < ar->dimen; i++) { - if (ref2->u.ar.type == AR_ELEMENT) + if (ar->type == AR_ELEMENT || ar->type == AR_FULL) goto check_symbols; switch (ar->dimen_type[i]) @@ -7201,6 +7275,7 @@ failure: return false; } + static void resolve_allocate_deallocate (gfc_code *code, const char *fcn) { @@ -7318,20 +7393,20 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) { if (pr == NULL && qr == NULL) { - gfc_error_1 ("Allocate-object at %L also appears at %L", - &pe->where, &qe->where); + gfc_error ("Allocate-object at %L also appears at %L", + &pe->where, &qe->where); break; } else if (pr != NULL && qr == NULL) { - gfc_error_1 ("Allocate-object at %L is subobject of" - " object at %L", &pe->where, &qe->where); + gfc_error ("Allocate-object at %L is subobject of" + " object at %L", &pe->where, &qe->where); break; } else if (pr == NULL && qr != NULL) { - gfc_error_1 ("Allocate-object at %L is subobject of" - " object at %L", &qe->where, &pe->where); + gfc_error ("Allocate-object at %L is subobject of" + " object at %L", &qe->where, &pe->where); break; } /* Here, pr != NULL && qr != NULL */ @@ -7375,8 +7450,16 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) if (strcmp (fcn, "ALLOCATE") == 0) { + bool arr_alloc_wo_spec = false; for (a = code->ext.alloc.list; a; a = a->next) - resolve_allocate_expr (a->expr, code); + resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec); + + if (arr_alloc_wo_spec && code->expr3) + { + /* Mark the allocate to have to take the array specification + from the expr3. */ + code->ext.alloc.arr_spec_from_expr3 = 1; + } } else { @@ -7534,7 +7617,7 @@ check_case_overlap (gfc_case *list) element in the list. Either way, we must issue an error and get the next case from P. */ /* FIXME: Sort P and Q by line number. */ - gfc_error_1 ("CASE label at %L overlaps with CASE " + gfc_error ("CASE label at %L overlaps with CASE " "label at %L", &p->where, &q->where); overlap_seen = 1; e = p; @@ -7772,7 +7855,7 @@ resolve_select (gfc_code *code, bool select_type) { if (default_case != NULL) { - gfc_error_1 ("The DEFAULT CASE at %L cannot be followed " + gfc_error ("The DEFAULT CASE at %L cannot be followed " "by a second DEFAULT CASE at %L", &default_case->where, &cp->where); t = false; @@ -7944,6 +8027,9 @@ gfc_type_is_extensible (gfc_symbol *sym) } +static void +resolve_types (gfc_namespace *ns); + /* Resolve an associate-name: Resolve target and ensure the type-spec is correct as well as possibly the array-spec. */ @@ -8006,6 +8092,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) return; } + /* We cannot deal with class selectors that need temporaries. */ if (target->ts.type == BT_CLASS && gfc_ref_needs_temporary_p (target->ref)) @@ -8015,22 +8102,81 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) return; } - if (target->ts.type != BT_CLASS && target->rank > 0) - sym->attr.dimension = 1; - else if (target->ts.type == BT_CLASS) + if (target->ts.type == BT_CLASS) gfc_fix_class_refs (target); - /* The associate-name will have a correct type by now. Make absolutely - sure that it has not picked up a dimension attribute. */ - if (sym->ts.type == BT_CLASS) - sym->attr.dimension = 0; - - if (sym->attr.dimension) + if (target->rank != 0) { - sym->as = gfc_get_array_spec (); - sym->as->rank = target->rank; - sym->as->type = AS_DEFERRED; - sym->as->corank = gfc_get_corank (target); + gfc_array_spec *as; + if (sym->ts.type != BT_CLASS && !sym->as) + { + as = gfc_get_array_spec (); + as->rank = target->rank; + as->type = AS_DEFERRED; + as->corank = gfc_get_corank (target); + sym->attr.dimension = 1; + if (as->corank != 0) + sym->attr.codimension = 1; + sym->as = as; + } + } + else + { + /* target's rank is 0, but the type of the sym is still array valued, + which has to be corrected. */ + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as) + { + gfc_array_spec *as; + symbol_attribute attr; + /* The associated variable's type is still the array type + correct this now. */ + gfc_typespec *ts = &target->ts; + gfc_ref *ref; + gfc_component *c; + for (ref = target->ref; ref != NULL; ref = ref->next) + { + switch (ref->type) + { + case REF_COMPONENT: + ts = &ref->u.c.component->ts; + break; + case REF_ARRAY: + if (ts->type == BT_CLASS) + ts = &ts->u.derived->components->ts; + break; + default: + break; + } + } + /* Create a scalar instance of the current class type. Because the + rank of a class array goes into its name, the type has to be + rebuild. The alternative of (re-)setting just the attributes + and as in the current type, destroys the type also in other + places. */ + as = NULL; + sym->ts = *ts; + sym->ts.type = BT_CLASS; + attr = CLASS_DATA (sym)->attr; + attr.class_ok = 0; + attr.associate_var = 1; + attr.dimension = attr.codimension = 0; + attr.class_pointer = 1; + if (!gfc_build_class_symbol (&sym->ts, &attr, &as)) + gcc_unreachable (); + /* Make sure the _vptr is set. */ + c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true); + if (c->ts.u.derived == NULL) + c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived); + CLASS_DATA (sym)->attr.pointer = 1; + CLASS_DATA (sym)->attr.class_pointer = 1; + gfc_set_sym_referenced (sym->ts.u.derived); + gfc_commit_symbol (sym->ts.u.derived); + /* _vptr now has the _vtab in it, change it to the _vtype. */ + if (c->ts.u.derived->attr.vtab) + c->ts.u.derived = c->ts.u.derived->ts.u.derived; + c->ts.u.derived->ns->types_resolved = 0; + resolve_types (c->ts.u.derived->ns); + } } /* Mark this as an associate variable. */ @@ -8145,7 +8291,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) /* Check F03:C818. */ if (default_case) { - gfc_error_1 ("The DEFAULT CASE at %L cannot be followed " + gfc_error ("The DEFAULT CASE at %L cannot be followed " "by a second DEFAULT CASE at %L", &default_case->ext.block.case_list->where, &c->where); error++; @@ -8708,7 +8854,7 @@ resolve_branch (gfc_st_label *label, gfc_code *code) if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET) { - gfc_error_1 ("Statement at %L is not a valid branch target statement " + gfc_error ("Statement at %L is not a valid branch target statement " "for the branch statement at %L", &label->where, &code->loc); return; } @@ -8735,11 +8881,11 @@ resolve_branch (gfc_st_label *label, gfc_code *code) { if (stack->current->op == EXEC_CRITICAL && bitmap_bit_p (stack->reachable_labels, label->value)) - gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for " + gfc_error ("GOTO statement at %L leaves CRITICAL construct for " "label at %L", &code->loc, &label->where); else if (stack->current->op == EXEC_DO_CONCURRENT && bitmap_bit_p (stack->reachable_labels, label->value)) - gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct " + gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct " "for label at %L", &code->loc, &label->where); } @@ -8758,13 +8904,13 @@ resolve_branch (gfc_st_label *label, gfc_code *code) { /* Note: A label at END CRITICAL does not leave the CRITICAL construct as END CRITICAL is still part of it. */ - gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for label" + gfc_error ("GOTO statement at %L leaves CRITICAL construct for label" " at %L", &code->loc, &label->where); return; } else if (stack->current->op == EXEC_DO_CONCURRENT) { - gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct for " + gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for " "label at %L", &code->loc, &label->where); return; } @@ -8779,7 +8925,7 @@ resolve_branch (gfc_st_label *label, gfc_code *code) /* The label is not in an enclosing block, so illegal. This was allowed in Fortran 66, so we allow it as extension. No further checks are necessary in this case. */ - gfc_notify_std_1 (GFC_STD_LEGACY, "Label at %L is not in the same block " + gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block " "as the GOTO statement at %L", &label->where, &code->loc); return; @@ -10545,7 +10691,7 @@ gfc_verify_binding_labels (gfc_symbol *sym) if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN) { - gfc_error_1 ("Variable %s with binding label %s at %L uses the same global " + gfc_error ("Variable %s with binding label %s at %L uses the same global " "identifier as entity at %L", sym->name, sym->binding_label, &sym->declared_at, &gsym->where); /* Clear the binding label to prevent checking multiple times. */ @@ -10558,7 +10704,7 @@ gfc_verify_binding_labels (gfc_symbol *sym) { /* This can only happen if the variable is defined in a module - if it isn't the same module, reject it. */ - gfc_error_1 ("Variable %s from module %s with binding label %s at %L uses " + gfc_error ("Variable %s from module %s with binding label %s at %L uses " "the same global identifier as entity at %L from module %s", sym->name, module, sym->binding_label, &sym->declared_at, &gsym->where, gsym->mod_name); @@ -10575,7 +10721,7 @@ gfc_verify_binding_labels (gfc_symbol *sym) /* Print an error if the procedure is defined multiple times; we have to exclude references to the same procedure via module association or multiple checks for the same procedure. */ - gfc_error_1 ("Procedure %s with binding label %s at %L uses the same " + gfc_error ("Procedure %s with binding label %s at %L uses the same " "global identifier as entity at %L", sym->name, sym->binding_label, &sym->declared_at, &gsym->where); sym->binding_label = NULL; @@ -10948,7 +11094,7 @@ apply_default_init_local (gfc_symbol *sym) result variable, which are also nonstatic. */ if (sym->attr.save || sym->ns->save_all || (flag_max_stack_var_size == 0 && !sym->attr.result - && !sym->ns->proc_name->attr.recursive + && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive) && (!sym->attr.dimension || !is_non_constant_shape_array (sym)))) { /* Don't clobber an existing initializer! */ @@ -11075,7 +11221,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) s = gfc_find_dt_in_generic (s); if (s && s->attr.flavor != FL_DERIVED) { - gfc_error_1 ("The type '%s' cannot be host associated at %L " + gfc_error ("The type %qs cannot be host associated at %L " "because it is blocked by an incompatible object " "of the same name declared at %L", sym->ts.u.derived->name, &sym->declared_at, @@ -11145,7 +11291,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) { /* The shape of a main program or module array needs to be constant. */ - gfc_error ("The module or main program array '%s' at %L must " + gfc_error ("The module or main program array %qs at %L must " "have constant shape", sym->name, &sym->declared_at); specification_expr = saved_specification_expr; return false; @@ -11194,7 +11340,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) && (sym->ns->proc_name->attr.flavor == FL_MODULE || sym->ns->proc_name->attr.is_main_program)) { - gfc_error ("'%s' at %L must have constant character length " + gfc_error ("%qs at %L must have constant character length " "in this context", sym->name, &sym->declared_at); specification_expr = saved_specification_expr; return false; @@ -11285,6 +11431,32 @@ no_init_error: } +/* Compare the dummy characteristics of a module procedure interface + declaration with the corresponding declaration in a submodule. */ +static gfc_formal_arglist *new_formal; +static char errmsg[200]; + +static void +compare_fsyms (gfc_symbol *sym) +{ + gfc_symbol *fsym; + + if (sym == NULL || new_formal == NULL) + return; + + fsym = new_formal->sym; + + if (sym == fsym) + return; + + if (strcmp (sym->name, fsym->name) == 0) + { + if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200)) + gfc_error ("%s at %L", errmsg, &fsym->declared_at); + } +} + + /* Resolve a procedure. */ static bool @@ -11549,6 +11721,71 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) if (sym->attr.if_source != IFSRC_DECL) sym->attr.array_outer_dependency = 1; + /* Compare the characteristics of a module procedure with the + interface declaration. Ideally this would be done with + gfc_compare_interfaces but, at present, the formal interface + cannot be copied to the ts.interface. */ + if (sym->attr.module_procedure + && sym->attr.if_source == IFSRC_DECL) + { + gfc_symbol *iface; + + /* Stop the dummy characteristics test from using the interface + symbol instead of 'sym'. */ + iface = sym->ts.interface; + sym->ts.interface = NULL; + + if (iface == NULL) + goto check_formal; + + /* Check the procedure characteristics. */ + if (sym->attr.pure != iface->attr.pure) + { + gfc_error ("Mismatch in PURE attribute between MODULE " + "PROCEDURE at %L and its interface in %s", + &sym->declared_at, iface->module); + return false; + } + + if (sym->attr.elemental != iface->attr.elemental) + { + gfc_error ("Mismatch in ELEMENTAL attribute between MODULE " + "PROCEDURE at %L and its interface in %s", + &sym->declared_at, iface->module); + return false; + } + + if (sym->attr.recursive != iface->attr.recursive) + { + gfc_error ("Mismatch in RECURSIVE attribute between MODULE " + "PROCEDURE at %L and its interface in %s", + &sym->declared_at, iface->module); + return false; + } + + /* Check the result characteristics. */ + if (!gfc_check_result_characteristics (sym, iface, errmsg, 200)) + { + gfc_error ("%s between the MODULE PROCEDURE declaration " + "in module %s and the declaration at %L in " + "SUBMODULE %s", errmsg, iface->module, + &sym->declared_at, sym->ns->proc_name->name); + return false; + } + +check_formal: + /* Check the charcateristics of the formal arguments. */ + if (sym->formal && sym->formal_ns) + { + for (arg = sym->formal; arg && arg->sym; arg = arg->next) + { + new_formal = arg; + gfc_traverse_ns (sym->formal_ns, compare_fsyms); + } + } + + sym->ts.interface = iface; + } return true; } @@ -12920,8 +13157,8 @@ resolve_fl_derived (gfc_symbol *sym) if (gen_dt && gen_dt->generic && gen_dt->generic->next && (!gen_dt->generic->sym->attr.use_assoc || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module) - && !gfc_notify_std_1 (GFC_STD_F2003, "Generic name '%s' of function " - "'%s' at %L being the same name as derived " + && !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function " + "%qs at %L being the same name as derived " "type at %L", sym->name, gen_dt->generic->sym == sym ? gen_dt->generic->next->sym->name @@ -13846,10 +14083,15 @@ 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->result && !a->function) || (a->dummy && a->intent == INTENT_OUT && !a->pointer)) apply_default_init (sym); + else if (a->function && sym->result && a->access != ACCESS_PRIVATE + && (sym->ts.u.derived->attr.alloc_comp + || sym->ts.u.derived->attr.pointer_comp)) + /* Mark the result symbol to be referenced, when it has allocatable + components. */ + sym->result->attr.referenced = 1; } if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns @@ -15070,6 +15312,7 @@ gfc_resolve (gfc_namespace *ns) { gfc_namespace *old_ns; code_stack *old_cs_base; + struct gfc_omp_saved_state old_omp_state; if (ns->resolved) return; @@ -15078,6 +15321,11 @@ gfc_resolve (gfc_namespace *ns) old_ns = gfc_current_ns; old_cs_base = cs_base; + /* As gfc_resolve can be called during resolution of an OpenMP construct + body, we should clear any state associated to it, so that say NS's + DO loops are not interpreted as OpenMP loops. */ + gfc_omp_save_and_clear_state (&old_omp_state); + resolve_types (ns); component_assignment_level = 0; resolve_codes (ns); @@ -15087,4 +15335,6 @@ gfc_resolve (gfc_namespace *ns) ns->resolved = 1; gfc_run_passes (ns); + + gfc_omp_restore_state (&old_omp_state); } diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c index f0e6404c625..bfb7d452e90 100644 --- a/gcc/fortran/scanner.c +++ b/gcc/fortran/scanner.c @@ -46,7 +46,7 @@ along with GCC; see the file COPYING3. If not see #include "gfortran.h" #include "toplev.h" /* For set_src_pwd. */ #include "debug.h" -#include "flags.h" +#include "options.h" #include "cpp.h" #include "scanner.h" @@ -1272,21 +1272,11 @@ restart: are still in a string and we are looking for a possible doubled quote and we end up here. See PR64506. */ - if (in_string) + if (in_string && c != '\n') { gfc_current_locus = old_loc; - - if (c == '!') - { - skip_comment_line (); - goto restart; - } - - if (c != '\n') - { - c = '&'; - goto done; - } + c = '&'; + goto done; } if (c != '!' && c != '\n') @@ -1392,6 +1382,8 @@ restart: "Missing %<&%> in continued character " "constant at %C"); } + else if (!in_string && (c == '\'' || c == '"')) + goto done; /* Both !$omp and !$ -fopenmp continuation lines have & on the continuation line only optionally. */ else if (openmp_flag || openacc_flag || openmp_cond_flag) @@ -2014,9 +2006,13 @@ preprocessor_line (gfc_char_t *c) if (!current_file->up || filename_cmp (current_file->up->filename, filename) != 0) { - gfc_warning_now_1 ("%s:%d: file %s left but not entered", - current_file->filename, current_file->line, - filename); + linemap_line_start (line_table, current_file->line, 80); + /* ??? One could compute the exact column where the filename + starts and compute the exact location here. */ + gfc_warning_now_at (linemap_position_for_column (line_table, 1), + 0, "file %qs left but not entered", + filename); + current_file->line++; if (unescape) free (wide_filename); free (filename); @@ -2048,8 +2044,11 @@ preprocessor_line (gfc_char_t *c) return; bad_cpp_line: - gfc_warning_now_1 ("%s:%d: Illegal preprocessor directive", - current_file->filename, current_file->line); + linemap_line_start (line_table, current_file->line, 80); + /* ??? One could compute the exact column where the directive + starts and compute the exact location here. */ + gfc_warning_now_at (linemap_position_for_column (line_table, 2), 0, + "Illegal preprocessor directive"); current_file->line++; } diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 92b3076b634..3fb98873709 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -21,7 +21,6 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "flags.h" #include "gfortran.h" #include "arith.h" #include "intrinsic.h" @@ -2352,9 +2351,7 @@ gfc_simplify_floor (gfc_expr *e, gfc_expr *k) if (e->expr_type != EXPR_CONSTANT) return NULL; - gfc_set_model_kind (kind); - - mpfr_init (floor); + mpfr_init2 (floor, mpfr_get_prec (e->value.real)); mpfr_floor (floor, e->value.real); result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); @@ -3338,31 +3335,45 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); /* Then, we need to know the extent of the given dimension. */ - if (coarray || ref->u.ar.type == AR_FULL) + if (coarray || (ref->u.ar.type == AR_FULL && !ref->next)) { + gfc_expr *declared_bound; + int empty_bound; + bool constant_lbound, constant_ubound; + l = as->lower[d-1]; u = as->upper[d-1]; - if (l->expr_type != EXPR_CONSTANT || u == NULL - || u->expr_type != EXPR_CONSTANT) + gcc_assert (l != NULL); + + constant_lbound = l->expr_type == EXPR_CONSTANT; + constant_ubound = u && u->expr_type == EXPR_CONSTANT; + + empty_bound = upper ? 0 : 1; + declared_bound = upper ? u : l; + + if ((!upper && !constant_lbound) + || (upper && !constant_ubound)) goto returnNull; - if (mpz_cmp (l->value.integer, u->value.integer) > 0) + if (!coarray) { - /* Zero extent. */ - if (upper) - mpz_set_si (result->value.integer, 0); + /* For {L,U}BOUND, the value depends on whether the array + is empty. We can nevertheless simplify if the declared bound + has the same value as that of an empty array, in which case + the result isn't dependent on the array emptyness. */ + if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0) + mpz_set_si (result->value.integer, empty_bound); + else if (!constant_lbound || !constant_ubound) + /* Array emptyness can't be determined, we can't simplify. */ + goto returnNull; + else if (mpz_cmp (l->value.integer, u->value.integer) > 0) + mpz_set_si (result->value.integer, empty_bound); else - mpz_set_si (result->value.integer, 1); + mpz_set (result->value.integer, declared_bound->value.integer); } else - { - /* Nonzero extent. */ - if (upper) - mpz_set (result->value.integer, u->value.integer); - else - mpz_set (result->value.integer, l->value.integer); - } + mpz_set (result->value.integer, declared_bound->value.integer); } else { @@ -3417,10 +3428,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) case AR_FULL: /* We're done because 'as' has already been set in the previous iteration. */ - if (!ref->next) - goto done; - - /* Fall through. */ + goto done; case AR_UNKNOWN: return NULL; @@ -3445,10 +3453,16 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) done: - if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE - || as->type == AS_ASSUMED_RANK)) + if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK + || (as->type == AS_ASSUMED_SHAPE && upper))) return NULL; + gcc_assert (!as + || (as->type != AS_DEFERRED + && array->expr_type == EXPR_VARIABLE + && !gfc_expr_attr (array).allocatable + && !gfc_expr_attr (array).pointer)); + if (dim == NULL) { /* Multi-dimensional bounds. */ @@ -3556,10 +3570,7 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) case AR_FULL: /* We're done because 'as' has already been set in the previous iteration. */ - if (!ref->next) - goto done; - - /* Fall through. */ + goto done; case AR_UNKNOWN: return NULL; @@ -5174,8 +5185,11 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, e = gfc_constructor_lookup_expr (source->value.constructor, j); else { - gcc_assert (npad > 0); - + if (npad <= 0) + { + mpz_clear (index); + return NULL; + } j = j - nsource; j = j % npad; e = gfc_constructor_lookup_expr (pad->value.constructor, j); diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 44392e8d191..52c5234276a 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -22,7 +22,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "flags.h" +#include "options.h" #include "gfortran.h" #include "parse.h" #include "match.h" @@ -458,6 +458,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) } } + if (attr->dummy && ((attr->function || attr->subroutine) && + gfc_current_state () == COMP_CONTAINS)) + gfc_error_now ("internal procedure '%s' at %L conflicts with " + "DUMMY argument", name, where); + conf (dummy, entry); conf (dummy, intrinsic); conf (dummy, threadprivate); @@ -1534,7 +1539,7 @@ gfc_add_procedure (symbol_attribute *attr, procedure_type t, if (where == NULL) where = &gfc_current_locus; - if (attr->proc != PROC_UNKNOWN) + if (attr->proc != PROC_UNKNOWN && !attr->module_procedure) { gfc_error ("%s procedure at %L is already declared as %s procedure", gfc_code2string (procedures, t), where, @@ -1650,10 +1655,15 @@ bool gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist * formal, locus *where) { - if (check_used (&sym->attr, sym->name, where)) return false; + /* Skip the following checks in the case of a module_procedures in a + submodule since they will manifestly fail. */ + if (sym->attr.module_procedure == 1 + && source == IFSRC_DECL) + goto finish; + if (where == NULL) where = &gfc_current_locus; @@ -1672,6 +1682,7 @@ gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source, return false; } +finish: sym->formal = formal; sym->attr.if_source = source; @@ -1698,10 +1709,13 @@ gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where) if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name) type = sym->ns->proc_name->ts.type; - if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type)) + if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type) + && !(gfc_state_stack->previous && gfc_state_stack->previous->previous + && gfc_state_stack->previous->previous->state == COMP_SUBMODULE) + && !sym->attr.module_procedure) { if (sym->attr.use_assoc) - gfc_error_1 ("Symbol '%s' at %L conflicts with symbol from module '%s', " + gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, " "use-associated at %L", sym->name, where, sym->module, &sym->declared_at); else @@ -1871,6 +1885,44 @@ fail: } +/* A function to generate a dummy argument symbol using that from the + interface declaration. Can be used for the result symbol as well if + the flag is set. */ + +int +gfc_copy_dummy_sym (gfc_symbol **dsym, gfc_symbol *sym, int result) +{ + int rc; + + rc = gfc_get_symbol (sym->name, NULL, dsym); + if (rc) + return rc; + + if (!gfc_add_type (*dsym, &(sym->ts), &gfc_current_locus)) + return 1; + + if (!gfc_copy_attr (&(*dsym)->attr, &(sym->attr), + &gfc_current_locus)) + return 1; + + if ((*dsym)->attr.dimension) + (*dsym)->as = gfc_copy_array_spec (sym->as); + + (*dsym)->attr.class_ok = sym->attr.class_ok; + + if ((*dsym) != NULL && !result + && (!gfc_add_dummy(&(*dsym)->attr, (*dsym)->name, NULL) + || !gfc_missing_attr (&(*dsym)->attr, NULL))) + return 1; + else if ((*dsym) != NULL && result + && (!gfc_add_result(&(*dsym)->attr, (*dsym)->name, NULL) + || !gfc_missing_attr (&(*dsym)->attr, NULL))) + return 1; + + return 0; +} + + /************** Component name management ************/ /* Component names of a derived type form their own little namespaces @@ -1895,7 +1947,7 @@ gfc_add_component (gfc_symbol *sym, const char *name, { if (strcmp (p->name, name) == 0) { - gfc_error_1 ("Component '%s' at %C already declared at %L", + gfc_error ("Component %qs at %C already declared at %L", name, &p->loc); return false; } @@ -1906,7 +1958,7 @@ gfc_add_component (gfc_symbol *sym, const char *name, if (sym->attr.extension && gfc_find_component (sym->components->ts.u.derived, name, true, true)) { - gfc_error_1 ("Component '%s' at %C already in the parent type " + gfc_error ("Component %qs at %C already in the parent type " "at %L", name, &sym->components->ts.u.derived->declared_at); return false; } @@ -2218,7 +2270,7 @@ gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus) labelno = lp->value; if (lp->defined != ST_LABEL_UNKNOWN) - gfc_error_1 ("Duplicate statement label %d at %L and %L", labelno, + gfc_error ("Duplicate statement label %d at %L and %L", labelno, &lp->where, label_locus); else { @@ -3895,9 +3947,9 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) J3/04-007, Section 15.2.3, C1505. */ if (curr_comp->attr.pointer != 0) { - gfc_error_1 ("Component '%s' at %L cannot have the " + gfc_error ("Component %qs at %L cannot have the " "POINTER attribute because it is a member " - "of the BIND(C) derived type '%s' at %L", + "of the BIND(C) derived type %qs at %L", curr_comp->name, &(curr_comp->loc), derived_sym->name, &(derived_sym->declared_at)); retval = false; @@ -3905,8 +3957,8 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) if (curr_comp->attr.proc_pointer != 0) { - gfc_error_1 ("Procedure pointer component '%s' at %L cannot be a member" - " of the BIND(C) derived type '%s' at %L", curr_comp->name, + gfc_error ("Procedure pointer component %qs at %L cannot be a member" + " of the BIND(C) derived type %qs at %L", curr_comp->name, &curr_comp->loc, derived_sym->name, &derived_sym->declared_at); retval = false; @@ -3916,9 +3968,9 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) J3/04-007, Section 15.2.3, C1505. */ if (curr_comp->attr.allocatable != 0) { - gfc_error_1 ("Component '%s' at %L cannot have the " + gfc_error ("Component %qs at %L cannot have the " "ALLOCATABLE attribute because it is a member " - "of the BIND(C) derived type '%s' at %L", + "of the BIND(C) derived type %qs at %L", curr_comp->name, &(curr_comp->loc), derived_sym->name, &(derived_sym->declared_at)); retval = false; @@ -4567,7 +4619,10 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) if (is_class1 && ts1->u.derived->components - && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic) + && ((ts1->u.derived->attr.is_class + && ts1->u.derived->components->ts.u.derived->attr + .unlimited_polymorphic) + || ts1->u.derived->attr.unlimited_polymorphic)) return 1; if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2) @@ -4578,13 +4633,21 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) if (is_derived1 && is_class2) return gfc_compare_derived_types (ts1->u.derived, - ts2->u.derived->components->ts.u.derived); + ts2->u.derived->attr.is_class ? + ts2->u.derived->components->ts.u.derived + : ts2->u.derived); if (is_class1 && is_derived2) - return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, + return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ? + ts1->u.derived->components->ts.u.derived + : ts1->u.derived, ts2->u.derived); else if (is_class1 && is_class2) - return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, - ts2->u.derived->components->ts.u.derived); + return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ? + ts1->u.derived->components->ts.u.derived + : ts1->u.derived, + ts2->u.derived->attr.is_class ? + ts2->u.derived->components->ts.u.derived + : ts2->u.derived); else return 0; } diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c index 4d636368d56..a58a97747c8 100644 --- a/gcc/fortran/target-memory.c +++ b/gcc/fortran/target-memory.c @@ -21,16 +21,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "flags.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" #include "fold-const.h" #include "stor-layout.h" @@ -671,8 +662,8 @@ expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len) gcc_assert (cmp && cmp->backend_decl); 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; + 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 (c->expr, &data[ptr], &chk[ptr], len); } return len; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 17689748eaf..c4cdbae1268 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -79,17 +79,9 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "gfortran.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "options.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" +#include "options.h" #include "fold-const.h" #include "gimple-expr.h" #include "diagnostic-core.h" /* For internal_error/fatal_error. */ @@ -101,7 +93,6 @@ along with GCC; see the file COPYING3. If not see #include "trans-array.h" #include "trans-const.h" #include "dependency.h" -#include "wide-int.h" static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base); @@ -2427,6 +2418,41 @@ set_vector_loop_bounds (gfc_ss * ss) } +/* Tells whether a scalar argument to an elemental procedure is saved out + of a scalarization loop as a value or as a reference. */ + +bool +gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info) +{ + if (ss_info->type != GFC_SS_REFERENCE) + return false; + + /* If the actual argument can be absent (in other words, it can + be a NULL reference), don't try to evaluate it; pass instead + the reference directly. */ + if (ss_info->can_be_null_ref) + return true; + + /* If the expression is of polymorphic type, it's actual size is not known, + so we avoid copying it anywhere. */ + if (ss_info->data.scalar.dummy_arg + && ss_info->data.scalar.dummy_arg->ts.type == BT_CLASS + && ss_info->expr->ts.type == BT_CLASS) + return true; + + /* If the expression is a data reference of aggregate type, + avoid a copy by saving a reference to the content. */ + if (ss_info->expr->expr_type == EXPR_VARIABLE + && (ss_info->expr->ts.type == BT_DERIVED + || ss_info->expr->ts.type == BT_CLASS)) + return true; + + /* Otherwise the expression is evaluated to a temporary variable before the + scalarization loop. */ + return false; +} + + /* Add the pre and post chains for all the scalar expressions in a SS chain to loop. This is called after the loop parameters have been calculated, but before the actual scalarizing loops. */ @@ -2495,16 +2521,11 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, case GFC_SS_REFERENCE: /* Scalar argument to elemental procedure. */ gfc_init_se (&se, NULL); - if (ss_info->can_be_null_ref) - { - /* If the actual argument can be absent (in other words, it can - be a NULL reference), don't try to evaluate it; pass instead - the reference directly. */ - gfc_conv_expr_reference (&se, expr); - } + if (gfc_scalar_elemental_arg_saved_as_reference (ss_info)) + gfc_conv_expr_reference (&se, expr); else { - /* Otherwise, evaluate the argument outside the loop and pass + /* Evaluate the argument outside the loop and pass a reference to the value. */ gfc_conv_expr (&se, expr); } @@ -3046,7 +3067,14 @@ build_class_array_ref (gfc_se *se, tree base, tree index) return false; } else if (class_ref == NULL) - decl = expr->symtree->n.sym->backend_decl; + { + decl = expr->symtree->n.sym->backend_decl; + /* For class arrays the tree containing the class is stored in + GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl. + For all others it's sym's backend_decl directly. */ + if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + } else { /* Remove everything after the last class reference, convert the @@ -3155,30 +3183,45 @@ add_to_offset (tree *cst_offset, tree *offset, tree t) static tree -build_array_ref (tree desc, tree offset, tree decl) +build_array_ref (tree desc, tree offset, tree decl, tree vptr) { tree tmp; tree type; + tree cdecl; + bool classarray = false; + + /* For class arrays the class declaration is stored in the saved + descriptor. */ + if (INDIRECT_REF_P (desc) + && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0)) + && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0))) + cdecl = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR ( + TREE_OPERAND (desc, 0))); + else + cdecl = desc; /* Class container types do not always have the GFC_CLASS_TYPE_P but the canonical type does. */ - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) - && TREE_CODE (desc) == COMPONENT_REF) + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdecl)) + && TREE_CODE (cdecl) == COMPONENT_REF) { - type = TREE_TYPE (TREE_OPERAND (desc, 0)); + type = TREE_TYPE (TREE_OPERAND (cdecl, 0)); if (TYPE_CANONICAL (type) && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type))) - type = TYPE_CANONICAL (type); + { + type = TREE_TYPE (desc); + classarray = true; + } } else type = NULL; /* Class array references need special treatment because the assigned type size needs to be used to point to the element. */ - if (type && GFC_CLASS_TYPE_P (type)) + if (classarray) { - type = gfc_get_element_type (TREE_TYPE (desc)); - tmp = TREE_OPERAND (desc, 0); + type = gfc_get_element_type (type); + tmp = TREE_OPERAND (cdecl, 0); tmp = gfc_get_class_array_ref (offset, tmp); tmp = fold_convert (build_pointer_type (type), tmp); tmp = build_fold_indirect_ref_loc (input_location, tmp); @@ -3187,7 +3230,7 @@ build_array_ref (tree desc, tree offset, tree decl) tmp = gfc_conv_array_data (desc); tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_build_array_ref (tmp, offset, decl); + tmp = gfc_build_array_ref (tmp, offset, decl, vptr); return tmp; } @@ -3350,7 +3393,8 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, offset, cst_offset); - se->expr = build_array_ref (se->expr, offset, sym->backend_decl); + se->expr = build_array_ref (se->expr, offset, sym->ts.type == BT_CLASS ? + NULL_TREE : sym->backend_decl, se->class_vptr); } @@ -3591,11 +3635,7 @@ gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, loopbody = gfc_finish_block (pbody); if (reverse_loop) - { - tmp = loop->from[n]; - loop->from[n] = loop->to[n]; - loop->to[n] = tmp; - } + std::swap (loop->from[n], loop->to[n]); /* Initialize the loopvar. */ if (loop->loopvar[n] != loop->from[n]) @@ -4409,7 +4449,7 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, if (!nDepend && dest_expr->rank > 0 && dest_expr->ts.type == BT_CHARACTER && ss_expr->expr_type == EXPR_VARIABLE) - + nDepend = gfc_check_dependency (dest_expr, ss_expr, false); continue; @@ -4956,7 +4996,8 @@ static tree gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, stmtblock_t * descriptor_block, tree * overflow, - tree expr3_elem_size, tree *nelems, gfc_expr *expr3) + tree expr3_elem_size, tree *nelems, gfc_expr *expr3, + tree expr3_desc, bool e3_is_array_constr) { tree type; tree tmp; @@ -4999,7 +5040,18 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, /* Set lower bound. */ gfc_init_se (&se, NULL); - if (lower == NULL) + if (expr3_desc != NULL_TREE) + { + if (e3_is_array_constr) + /* The lbound of a constant array [] starts at zero, but when + allocating it, the standard expects the array to start at + one. */ + se.expr = gfc_index_one_node; + else + se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, + gfc_rank_cst[n]); + } + else if (lower == NULL) se.expr = gfc_index_one_node; else { @@ -5027,10 +5079,35 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, /* Set upper bound. */ 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); - + if (expr3_desc != NULL_TREE) + { + if (e3_is_array_constr) + { + /* The lbound of a constant array [] starts at zero, but when + allocating it, the standard expects the array to start at + one. Therefore fix the upper bound to be + (desc.ubound - desc.lbound)+ 1. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_conv_descriptor_ubound_get ( + expr3_desc, gfc_rank_cst[n]), + gfc_conv_descriptor_lbound_get ( + expr3_desc, gfc_rank_cst[n])); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); + se.expr = gfc_evaluate_now (tmp, pblock); + } + else + se.expr = gfc_conv_descriptor_ubound_get (expr3_desc, + gfc_rank_cst[n]); + } + else + { + 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 (descriptor_block, descriptor, gfc_rank_cst[n], se.expr); conv_ubound = se.expr; @@ -5200,6 +5277,33 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, } +/* Retrieve the last ref from the chain. This routine is specific to + gfc_array_allocate ()'s needs. */ + +bool +retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in) +{ + gfc_ref *ref, *prev_ref; + + ref = *ref_in; + /* Prevent warnings for uninitialized variables. */ + prev_ref = *prev_ref_in; + while (ref && ref->next != NULL) + { + 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; + } + + if (ref == NULL || ref->type != REF_ARRAY) + return false; + + *ref_in = ref; + *prev_ref_in = prev_ref; + return true; +} + /* Initializes the descriptor and generates a call to _gfor_allocate. Does the work for an ALLOCATE statement. */ /*GCC ARRAYS*/ @@ -5207,7 +5311,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, tree errlen, tree label_finish, tree expr3_elem_size, - tree *nelems, gfc_expr *expr3) + tree *nelems, gfc_expr *expr3, tree e3_arr_desc, + bool e3_is_array_constr) { tree tmp; tree pointer; @@ -5225,21 +5330,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, gfc_expr **lower; gfc_expr **upper; gfc_ref *ref, *prev_ref = NULL; - bool allocatable, coarray, dimension; + bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false; ref = expr->ref; /* Find the last reference in the chain. */ - while (ref && ref->next != NULL) + if (!retrieve_last_ref (&ref, &prev_ref)) + return false; + + if (ref->u.ar.type == AR_FULL && expr3 != NULL) { - 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; - } + /* F08:C633: Array shape from expr3. */ + ref = expr3->ref; - if (ref == NULL || ref->type != REF_ARRAY) - return false; + /* Find the last reference in the chain. */ + if (!retrieve_last_ref (&ref, &prev_ref)) + return false; + alloc_w_e3_arr_spec = true; + } if (!prev_ref) { @@ -5275,7 +5383,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, break; case AR_FULL: - gcc_assert (ref->u.ar.as->type == AS_EXPLICIT); + gcc_assert (ref->u.ar.as->type == AS_EXPLICIT + || alloc_w_e3_arr_spec); lower = ref->u.ar.as->lower; upper = ref->u.ar.as->upper; @@ -5289,10 +5398,12 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, overflow = integer_zero_node; gfc_init_block (&set_descriptor_block); - size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, + size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank + : ref->u.ar.as->rank, ref->u.ar.as->corank, &offset, lower, upper, &se->pre, &set_descriptor_block, &overflow, - expr3_elem_size, nelems, expr3); + expr3_elem_size, nelems, expr3, e3_arr_desc, + e3_is_array_constr); if (dimension) { @@ -5570,7 +5681,7 @@ gfc_trans_array_cobounds (tree type, stmtblock_t * pblock, gfc_se se; gfc_array_spec *as; - as = sym->as; + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; for (dim = as->rank; dim < as->rank + as->corank; dim++) { @@ -5613,7 +5724,7 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, int dim; - as = sym->as; + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; size = gfc_index_one_node; offset = gfc_index_zero_node; @@ -5900,12 +6011,17 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, int checkparm; int no_repack; bool optional_arg; + gfc_array_spec *as; + bool is_classarray = IS_CLASS_ARRAY (sym); /* Do nothing for pointer and allocatable arrays. */ - if (sym->attr.pointer || sym->attr.allocatable) + if ((sym->ts.type != BT_CLASS && sym->attr.pointer) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) + || sym->attr.allocatable + || (is_classarray && CLASS_DATA (sym)->attr.allocatable)) return; - if (sym->attr.dummy && gfc_is_nodesc_array (sym)) + if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym)) { gfc_trans_g77_array (sym, block); return; @@ -5918,14 +6034,20 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, 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); + if (is_classarray) + /* For a class array the dummy array descriptor is in the _class + component. */ + dumdesc = gfc_class_data_get (dumdesc); + else + dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc); + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; 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, &init); - checkparm = (sym->as->type == AS_EXPLICIT + checkparm = (as->type == AS_EXPLICIT && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)); no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc) @@ -6001,9 +6123,9 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, size = gfc_index_one_node; /* Evaluate the bounds of the array. */ - for (n = 0; n < sym->as->rank; n++) + for (n = 0; n < as->rank; n++) { - if (checkparm || !sym->as->upper[n]) + if (checkparm || !as->upper[n]) { /* Get the bounds of the actual parameter. */ dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]); @@ -6019,7 +6141,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, if (!INTEGER_CST_P (lbound)) { gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, sym->as->lower[n], + gfc_conv_expr_type (&se, as->lower[n], gfc_array_index_type); gfc_add_block_to_block (&init, &se.pre); gfc_add_modify (&init, lbound, se.expr); @@ -6027,13 +6149,13 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, ubound = GFC_TYPE_ARRAY_UBOUND (type, n); /* Set the desired upper bound. */ - if (sym->as->upper[n]) + if (as->upper[n]) { /* We know what we want the upper bound to be. */ if (!INTEGER_CST_P (ubound)) { gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, sym->as->upper[n], + gfc_conv_expr_type (&se, as->upper[n], gfc_array_index_type); gfc_add_block_to_block (&init, &se.pre); gfc_add_modify (&init, ubound, se.expr); @@ -6086,7 +6208,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, gfc_array_index_type, offset, tmp); /* The size of this dimension, and the stride of the next. */ - if (n + 1 < sym->as->rank) + if (n + 1 < as->rank) { stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1); @@ -6234,7 +6356,7 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset, return; } - tmp = build_array_ref (desc, offset, NULL); + tmp = build_array_ref (desc, offset, NULL, NULL); /* Offset the data pointer for pointer assignments from arrays with subreferences; e.g. my_integer => my_type(:)%integer_component. */ @@ -6789,8 +6911,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) tree from; tree to; tree base; + bool onebased = false, rank_remap; ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen; + rank_remap = ss->dimen < ndim; if (se->want_coarray) { @@ -6823,6 +6947,22 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) if (expr->ts.type == BT_CHARACTER) se->string_length = gfc_get_expr_charlen (expr); + /* If we have an array section or are assigning make sure that + the lower bound is 1. References to the full + array should otherwise keep the original bounds. */ + if ((!info->ref || info->ref->u.ar.type != AR_FULL) && !se->want_pointer) + for (dim = 0; dim < loop.dimen; dim++) + if (!integer_onep (loop.from[dim])) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, gfc_index_one_node, + loop.from[dim]); + loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + loop.to[dim], tmp); + loop.from[dim] = gfc_index_one_node; + } + desc = info->descriptor; if (se->direct_byref && !se->byref_noassign) { @@ -6916,20 +7056,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) from = loop.from[dim]; to = loop.to[dim]; - /* If we have an array section or are assigning make sure that - the lower bound is 1. References to the full - array should otherwise keep the original bounds. */ - if ((!info->ref - || info->ref->u.ar.type != AR_FULL) - && !integer_onep (from)) - { - 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; - } + onebased = integer_onep (from); gfc_conv_descriptor_lbound_set (&loop.pre, parm, gfc_rank_cst[dim], from); @@ -6954,7 +7081,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) { tmp = gfc_conv_array_lbound (desc, n); tmp = fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (base), tmp, loop.from[dim]); + TREE_TYPE (base), tmp, from); tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (base), tmp, gfc_conv_array_stride (desc, n)); @@ -6986,12 +7113,35 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_get_dataptr_offset (&loop.pre, parm, desc, offset, subref_array_target, expr); + /* Force the offset to be -1, when the lower bound of the highest + dimension is one and the symbol is present and is not a + pointer/allocatable or associated. */ if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) && !se->data_not_needed) || (se->use_offset && base != NULL_TREE)) { - /* Set the offset. */ - gfc_conv_descriptor_offset_set (&loop.pre, parm, base); + /* Set the offset depending on base. */ + tmp = rank_remap && !se->direct_byref ? + fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, base, + offset) + : base; + gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp); + } + else if (onebased && (!rank_remap || se->use_offset) + && expr->symtree + && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS + && !CLASS_DATA (expr->symtree->n.sym)->attr.class_pointer) + && !expr->symtree->n.sym->attr.allocatable + && !expr->symtree->n.sym->attr.pointer + && !expr->symtree->n.sym->attr.host_assoc + && !expr->symtree->n.sym->attr.use_assoc) + { + /* Set the offset to -1. */ + mpz_t minus_one; + mpz_init_set_si (minus_one, -1); + tmp = gfc_conv_mpz_to_tree (minus_one, gfc_index_integer_kind); + gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp); } else { @@ -7002,6 +7152,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) desc = parm; } + /* For class arrays add the class tree into the saved descriptor to + enable getting of _vptr and the like. */ + if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc) + && IS_CLASS_ARRAY (expr->symtree->n.sym) + && DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl)) + { + gfc_allocate_lang_decl (desc); + GFC_DECL_SAVED_DESCRIPTOR (desc) = + GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl); + } if (!se->direct_byref || se->byref_noassign) { /* Get a pointer to the new descriptor. */ @@ -7189,6 +7349,17 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp) { gfc_conv_expr_descriptor (se, expr); + /* Deallocate the allocatable components of structures that are + not variable. */ + if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) + && expr->ts.u.derived->attr.alloc_comp + && expr->expr_type != EXPR_VARIABLE) + { + tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank); + + /* The components shall be deallocated before their containing entity. */ + gfc_prepend_expr_to_block (&se->post, tmp); + } if (expr->ts.type == BT_CHARACTER) se->string_length = expr->ts.u.cl->backend_decl; if (size) @@ -7224,10 +7395,11 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, } /* Deallocate the allocatable components of structures that are - not variable. */ - if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) - && expr->ts.u.derived->attr.alloc_comp - && expr->expr_type != EXPR_VARIABLE) + not variable, for descriptorless arguments. + Arguments with a descriptor are handled in gfc_conv_procedure_call. */ + if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) + && expr->ts.u.derived->attr.alloc_comp + && expr->expr_type != EXPR_VARIABLE) { tmp = build_fold_indirect_ref_loc (input_location, se->expr); tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank); @@ -7468,7 +7640,8 @@ gfc_full_array_size (stmtblock_t *block, tree decl, int rank) static tree duplicate_allocatable (tree dest, tree src, tree type, int rank, - bool no_malloc, bool no_memcpy, tree str_sz) + bool no_malloc, bool no_memcpy, tree str_sz, + tree add_when_allocated) { tree tmp; tree size; @@ -7548,6 +7721,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, } } + gfc_add_expr_to_block (&block, add_when_allocated); tmp = gfc_finish_block (&block); /* Null the destination if the source is null; otherwise do @@ -7567,10 +7741,11 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, /* Allocate dest to the same size as src, and copy data src -> dest. */ tree -gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank) +gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank, + tree add_when_allocated) { return duplicate_allocatable (dest, src, type, rank, false, false, - NULL_TREE); + NULL_TREE, add_when_allocated); } @@ -7580,7 +7755,7 @@ tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) { return duplicate_allocatable (dest, src, type, rank, true, false, - NULL_TREE); + NULL_TREE, NULL_TREE); } /* Allocate dest to the same size as src, but don't copy anything. */ @@ -7588,7 +7763,8 @@ gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) tree gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank) { - return duplicate_allocatable (dest, src, type, rank, false, true, NULL_TREE); + return duplicate_allocatable (dest, src, type, rank, false, true, + NULL_TREE, NULL_TREE); } @@ -7620,27 +7796,32 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree ctype; tree vref, dref; tree null_cond = NULL_TREE; + tree add_when_allocated; bool called_dealloc_with_status; gfc_init_block (&fnblock); decl_type = TREE_TYPE (decl); - if ((POINTER_TYPE_P (decl_type) && rank != 0) + if ((POINTER_TYPE_P (decl_type)) || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0)) - decl = build_fold_indirect_ref_loc (input_location, decl); + { + decl = build_fold_indirect_ref_loc (input_location, decl); + /* Deref dest in sync with decl, but only when it is not NULL. */ + if (dest) + dest = build_fold_indirect_ref_loc (input_location, dest); + } - /* Just in case in gets dereferenced. */ + /* Just in case it gets dereferenced. */ decl_type = TREE_TYPE (decl); - /* If this an array of derived types with allocatable components + /* If this is an array of derived types with allocatable components build a loop and recursively call this function. */ if (TREE_CODE (decl_type) == ARRAY_TYPE || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0)) { tmp = gfc_conv_array_data (decl); - var = build_fold_indirect_ref_loc (input_location, - tmp); + var = build_fold_indirect_ref_loc (input_location, tmp); /* Get the number of elements - 1 and set the counter. */ if (GFC_DESCRIPTOR_TYPE_P (decl_type)) @@ -7661,7 +7842,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, else { /* Otherwise use the TYPE_DOMAIN information. */ - tmp = array_type_nelts (decl_type); + tmp = array_type_nelts (decl_type); tmp = fold_convert (gfc_array_index_type, tmp); } @@ -7674,19 +7855,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, vref = gfc_build_array_ref (var, index, NULL); - if (purpose == COPY_ALLOC_COMP) - { - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) - { - tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank); - gfc_add_expr_to_block (&fnblock, tmp); - } - tmp = build_fold_indirect_ref_loc (input_location, - gfc_conv_array_data (dest)); - dref = gfc_build_array_ref (tmp, index, NULL); - tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose); - } - else if (purpose == COPY_ONLY_ALLOC_COMP) + if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP) { tmp = build_fold_indirect_ref_loc (input_location, gfc_conv_array_data (dest)); @@ -7709,7 +7878,17 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_add_block_to_block (&fnblock, &loop.pre); tmp = gfc_finish_block (&fnblock); - if (null_cond != NULL_TREE) + /* When copying allocateable components, the above implements the + deep copy. Nevertheless is a deep copy only allowed, when the current + component is allocated, for which code will be generated in + gfc_duplicate_allocatable (), where the deep copy code is just added + into the if's body, by adding tmp (the deep copy code) as last + argument to gfc_duplicate_allocatable (). */ + if (purpose == COPY_ALLOC_COMP + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) + tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank, + tmp); + else if (null_cond != NULL_TREE) tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt (input_location)); @@ -7994,6 +8173,22 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, continue; } + /* To implement guarded deep copy, i.e., deep copy only allocatable + components that are really allocated, the deep copy code has to + be generated first and then added to the if-block in + gfc_duplicate_allocatable (). */ + if (cmp_has_alloc_comps) + { + rank = c->as ? c->as->rank : 0; + tmp = fold_convert (TREE_TYPE (dcmp), comp); + gfc_add_modify (&fnblock, dcmp, tmp); + add_when_allocated = structure_alloc_comps (c->ts.u.derived, + comp, dcmp, + rank, purpose); + } + else + add_when_allocated = NULL_TREE; + if (gfc_deferred_strlen (c, &tmp)) { tree len, size; @@ -8008,30 +8203,29 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, TREE_TYPE (len), len, tmp); gfc_add_expr_to_block (&fnblock, tmp); size = size_of_string_in_bytes (c->ts.kind, len); + /* This component can not have allocatable components, + therefore add_when_allocated of duplicate_allocatable () + is always NULL. */ tmp = duplicate_allocatable (dcmp, comp, ctype, rank, - false, false, size); + false, false, size, NULL_TREE); gfc_add_expr_to_block (&fnblock, tmp); } else if (c->attr.allocatable && !c->attr.proc_pointer - && !cmp_has_alloc_comps) + && (!(cmp_has_alloc_comps && c->as) + || c->attr.codimension)) { rank = c->as ? c->as->rank : 0; if (c->attr.codimension) tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank); else - tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank); + tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank, + add_when_allocated); gfc_add_expr_to_block (&fnblock, tmp); } + else + if (cmp_has_alloc_comps) + gfc_add_expr_to_block (&fnblock, add_when_allocated); - if (cmp_has_alloc_comps) - { - rank = c->as ? c->as->rank : 0; - tmp = fold_convert (TREE_TYPE (dcmp), comp); - gfc_add_modify (&fnblock, dcmp, tmp); - tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp, - rank, purpose); - gfc_add_expr_to_block (&fnblock, tmp); - } break; default: @@ -8972,7 +9166,11 @@ gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref) return NULL; /* Normal procedure case. */ - sym = procedure_ref->symtree->n.sym; + if (procedure_ref->expr_type == EXPR_FUNCTION + && procedure_ref->value.function.esym) + sym = procedure_ref->value.function.esym; + else + sym = procedure_ref->symtree->n.sym; /* Typebound procedure case. */ for (ref = procedure_ref->ref; ref; ref = ref->next) @@ -9015,7 +9213,7 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, for (; arg; arg = arg->next) { if (!arg->expr || arg->expr->expr_type == EXPR_NULL) - continue; + goto loop_continue; newss = gfc_walk_subexpr (head, arg->expr); if (newss == head) @@ -9024,7 +9222,8 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE); newss = gfc_get_scalar_ss (head, arg->expr); newss->info->type = type; - + if (dummy_arg) + newss->info->data.scalar.dummy_arg = dummy_arg->sym; } else scalar = 0; @@ -9045,6 +9244,7 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, tail = tail->next; } +loop_continue: if (dummy_arg != NULL) dummy_arg = dummy_arg->next; } diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 854453490aa..52f1c9aef89 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -24,7 +24,7 @@ tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*); /* Generate code to initialize and allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, - tree, tree *, gfc_expr *); + tree, tree *, gfc_expr *, tree, bool); /* Allow the bounds of a loop to be set from a callee's array spec. */ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, @@ -46,7 +46,7 @@ tree gfc_trans_dealloc_allocated (tree, bool, gfc_expr *); tree gfc_full_array_size (stmtblock_t *, tree, int); -tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank); +tree gfc_duplicate_allocatable (tree, tree, tree, int, tree); tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank); @@ -64,8 +64,6 @@ tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int); tree gfc_alloc_allocatable_for_assignment (gfc_loopinfo*, gfc_expr*, gfc_expr*); -bool gfc_is_reallocatable_lhs (gfc_expr *); - /* Add initialization for deferred arrays. */ void gfc_trans_deferred_array (gfc_symbol *, gfc_wrapped_block *); /* Generate an initializer for a static pointer or allocatable array. */ @@ -105,6 +103,8 @@ gfc_ss *gfc_get_temp_ss (tree, tree, int); /* Allocate a new scalar type ss. */ gfc_ss *gfc_get_scalar_ss (gfc_ss *, gfc_expr *); +bool gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info *); + /* Calculates the lower bound and stride of array sections. */ void gfc_conv_ss_startstride (gfc_loopinfo *); diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index 8064d891870..7f4bfe58c69 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -92,20 +92,14 @@ along with GCC; see the file COPYING3. If not see is examined for still-unused equivalence conditions. We create a block for each merged equivalence list. */ -#include <map> #include "config.h" #include "system.h" + +#include <map> + #include "coretypes.h" #include "tm.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" #include "fold-const.h" #include "stringpool.h" @@ -918,8 +912,8 @@ confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2, offset2 = calculate_offset (eq2->expr); if (s1->offset + offset1 != s2->offset + offset2) - gfc_error_1 ("Inconsistent equivalence rules involving '%s' at %L and " - "'%s' at %L", s1->sym->name, &s1->sym->declared_at, + gfc_error ("Inconsistent equivalence rules involving %qs at %L and " + "%qs at %L", s1->sym->name, &s1->sym->declared_at, s2->sym->name, &s2->sym->declared_at); } diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c index 76463449522..1d1e9634633 100644 --- a/gcc/fortran/trans-const.c +++ b/gcc/fortran/trans-const.c @@ -24,23 +24,13 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "gfortran.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "options.h" -#include "real.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" +#include "options.h" #include "fold-const.h" #include "stor-layout.h" #include "realmpfr.h" #include "diagnostic-core.h" /* For fatal_error. */ -#include "double-int.h" #include "trans.h" #include "trans-const.h" #include "trans-types.h" diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 769d487c7d9..f95ca167c2f 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -25,15 +25,7 @@ along with GCC; see the file COPYING3. If not see #include "coretypes.h" #include "tm.h" #include "gfortran.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" #include "fold-const.h" #include "stringpool.h" @@ -42,18 +34,12 @@ along with GCC; see the file COPYING3. If not see #include "attribs.h" #include "tree-dump.h" #include "gimple-expr.h" /* For create_tmp_var_raw. */ -#include "ggc.h" #include "diagnostic-core.h" /* For internal_error. */ #include "toplev.h" /* For announce_function. */ #include "target.h" #include "hard-reg-set.h" -#include "input.h" #include "function.h" #include "flags.h" -#include "hash-map.h" -#include "is-a.h" -#include "plugin-api.h" -#include "ipa-ref.h" #include "cgraph.h" #include "debug.h" #include "constructor.h" @@ -390,9 +376,10 @@ gfc_sym_mangled_function_id (gfc_symbol * sym) /* use the binding label rather than the mangled name */ return get_identifier (sym->binding_label); - if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL + if ((sym->module == NULL || sym->attr.proc == PROC_EXTERNAL || (sym->module != NULL && (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY))) + && !sym->attr.module_procedure) { /* Main program is mangled into MAIN__. */ if (sym->attr.is_main_program) @@ -612,7 +599,7 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) } /* If a variable is USE associated, it's always external. */ - if (sym->attr.use_assoc) + if (sym->attr.use_assoc || sym->attr.used_in_submodule) { DECL_EXTERNAL (decl) = 1; TREE_PUBLIC (decl) = 1; @@ -812,8 +799,13 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) int dim; int nest; gfc_namespace* procns; + symbol_attribute *array_attr; + gfc_array_spec *as; + bool is_classarray = IS_CLASS_ARRAY (sym); type = TREE_TYPE (decl); + array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; + as = is_classarray ? CLASS_DATA (sym)->as : sym->as; /* We just use the descriptor, if there is one. */ if (GFC_DESCRIPTOR_TYPE_P (type)) @@ -824,8 +816,8 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) nest = (procns->proc_name->backend_decl != current_function_decl) && !sym->attr.contained; - if (sym->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB - && sym->as->type != AS_ASSUMED_SHAPE + if (array_attr->codimension && flag_coarray == GFC_FCOARRAY_LIB + && as->type != AS_ASSUMED_SHAPE && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE) { tree token; @@ -878,8 +870,8 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) } /* Don't try to use the unknown bound for assumed shape arrays. */ if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE - && (sym->as->type != AS_ASSUMED_SIZE - || dim < GFC_TYPE_ARRAY_RANK (type) - 1)) + && (as->type != AS_ASSUMED_SIZE + || dim < GFC_TYPE_ARRAY_RANK (type) - 1)) { GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest); TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1; @@ -920,7 +912,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) } if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE - && sym->as->type != AS_ASSUMED_SIZE) + && as->type != AS_ASSUMED_SIZE) { GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest); TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1; @@ -947,12 +939,12 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) } if (TYPE_NAME (type) != NULL_TREE - && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE - && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL) + && GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1) != NULL_TREE + && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1)) == VAR_DECL) { tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type)); - for (dim = 0; dim < sym->as->rank - 1; dim++) + for (dim = 0; dim < as->rank - 1; dim++) { gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE); gtype = TREE_TYPE (gtype); @@ -966,7 +958,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) { tree gtype = TREE_TYPE (type), rtype, type_decl; - for (dim = sym->as->rank - 1; dim >= 0; dim--) + for (dim = as->rank - 1; dim >= 0; dim--) { tree lbound, ubound; lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); @@ -1014,41 +1006,56 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) tree decl; tree type; gfc_array_spec *as; + symbol_attribute *array_attr; char *name; gfc_packed packed; int n; bool known_size; - - if (sym->attr.pointer || sym->attr.allocatable - || (sym->as && sym->as->type == AS_ASSUMED_RANK)) + bool is_classarray = IS_CLASS_ARRAY (sym); + + /* Use the array as and attr. */ + as = is_classarray ? CLASS_DATA (sym)->as : sym->as; + array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; + + /* The dummy is returned for pointer, allocatable or assumed rank arrays. + For class arrays the information if sym is an allocatable or pointer + object needs to be checked explicitly (IS_CLASS_ARRAY can be false for + too many reasons to be of use here). */ + if ((sym->ts.type != BT_CLASS && sym->attr.pointer) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) + || array_attr->allocatable + || (as && as->type == AS_ASSUMED_RANK)) return dummy; - /* Add to list of variables if not a fake result variable. */ + /* Add to list of variables if not a fake result variable. + These symbols are set on the symbol only, not on the class component. */ if (sym->attr.result || sym->attr.dummy) gfc_defer_symbol_init (sym); - type = TREE_TYPE (dummy); + /* For a class array the array descriptor is in the _data component, while + for a regular array the TREE_TYPE of the dummy is a pointer to the + descriptor. */ + type = TREE_TYPE (is_classarray ? gfc_class_data_get (dummy) + : TREE_TYPE (dummy)); + /* type now is the array descriptor w/o any indirection. */ gcc_assert (TREE_CODE (dummy) == PARM_DECL - && POINTER_TYPE_P (type)); + && POINTER_TYPE_P (TREE_TYPE (dummy))); /* Do we know the element size? */ known_size = sym->ts.type != BT_CHARACTER || INTEGER_CST_P (sym->ts.u.cl->backend_decl); - if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))) + if (known_size && !GFC_DESCRIPTOR_TYPE_P (type)) { /* For descriptorless arrays with known element size the actual argument is sufficient. */ - gcc_assert (GFC_ARRAY_TYPE_P (type)); gfc_build_qualified_array (dummy, sym); return dummy; } - type = TREE_TYPE (type); if (GFC_DESCRIPTOR_TYPE_P (type)) { /* Create a descriptorless array pointer. */ - as = sym->as; packed = PACKED_NO; /* Even when -frepack-arrays is used, symbols with TARGET attribute @@ -1079,8 +1086,11 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) packed = PACKED_PARTIAL; } - type = gfc_typenode_for_spec (&sym->ts); - type = gfc_get_nodesc_array_type (type, sym->as, packed, + /* For classarrays the element type is required, but + gfc_typenode_for_spec () returns the array descriptor. */ + type = is_classarray ? gfc_get_element_type (type) + : gfc_typenode_for_spec (&sym->ts); + type = gfc_get_nodesc_array_type (type, as, packed, !sym->attr.target); } else @@ -1110,7 +1120,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) /* We should never get deferred shape arrays here. We used to because of frontend bugs. */ - gcc_assert (sym->as->type != AS_DEFERRED); + gcc_assert (as->type != AS_DEFERRED); if (packed == PACKED_PARTIAL) GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1; @@ -1309,6 +1319,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) gcc_assert (sym->attr.referenced || sym->attr.flavor == FL_PROCEDURE || sym->attr.use_assoc + || sym->attr.used_in_submodule || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY || (sym->module && sym->attr.if_source != IFSRC_DECL && sym->backend_decl)); @@ -1429,13 +1440,30 @@ gfc_get_symbol_decl (gfc_symbol * sym) sym->backend_decl = decl; } + /* Returning the descriptor for dummy class arrays is hazardous, because + some caller is expecting an expression to apply the component refs to. + Therefore the descriptor is only created and stored in + sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller is then + responsible to extract it from there, when the descriptor is + desired. */ + if (IS_CLASS_ARRAY (sym) + && (!DECL_LANG_SPECIFIC (sym->backend_decl) + || !GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl))) + { + decl = gfc_build_dummy_array_decl (sym, sym->backend_decl); + /* Prevent the dummy from being detected as unused if it is copied. */ + if (sym->backend_decl != NULL && decl != sym->backend_decl) + DECL_ARTIFICIAL (sym->backend_decl) = 1; + sym->backend_decl = decl; + } + TREE_USED (sym->backend_decl) = 1; if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0) { gfc_add_assign_aux_vars (sym); } - if (sym->attr.dimension + if ((sym->attr.dimension || IS_CLASS_ARRAY (sym)) && DECL_LANG_SPECIFIC (sym->backend_decl) && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl) && DECL_CONTEXT (sym->backend_decl) != current_function_decl) @@ -3976,18 +4004,31 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp); TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1; } - else if (sym->attr.dimension || sym->attr.codimension) + else if (sym->attr.dimension || sym->attr.codimension + || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable)) { - /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */ - array_type tmp = sym->as->type; - if (tmp == AS_ASSUMED_SIZE && sym->as->cp_was_assumed) - tmp = AS_EXPLICIT; - switch (tmp) + bool is_classarray = IS_CLASS_ARRAY (sym); + symbol_attribute *array_attr; + gfc_array_spec *as; + array_type tmp; + + array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; + as = is_classarray ? CLASS_DATA (sym)->as : sym->as; + /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */ + tmp = as->type; + if (tmp == AS_ASSUMED_SIZE && as->cp_was_assumed) + tmp = AS_EXPLICIT; + switch (tmp) { case AS_EXPLICIT: if (sym->attr.dummy || sym->attr.result) gfc_trans_dummy_array_bias (sym, sym->backend_decl, block); - else if (sym->attr.pointer || sym->attr.allocatable) + /* Allocatable and pointer arrays need to processed + explicitly. */ + else if ((sym->ts.type != BT_CLASS && sym->attr.pointer) + || (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.class_pointer) + || array_attr->allocatable) { if (TREE_STATIC (sym->backend_decl)) { @@ -4002,7 +4043,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_trans_deferred_array (sym, block); } } - else if (sym->attr.codimension && TREE_STATIC (sym->backend_decl)) + else if (sym->attr.codimension + && TREE_STATIC (sym->backend_decl)) { gfc_init_block (&tmpblock); gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl), @@ -4041,7 +4083,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) case AS_ASSUMED_SIZE: /* Must be a dummy parameter. */ - gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed); + gcc_assert (sym->attr.dummy || as->cp_was_assumed); /* We should always pass assumed size arrays the g77 way. */ if (sym->attr.dummy) @@ -4103,6 +4145,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) } else { + se.descriptor_only = 1; gfc_conv_expr (&se, e); descriptor = se.expr; se.expr = gfc_conv_descriptor_data_addr (se.expr); @@ -4316,7 +4359,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE); } -struct module_hasher : ggc_hasher<module_htab_entry *> +struct module_hasher : ggc_ptr_hash<module_htab_entry> { typedef const char *compare_type; @@ -4776,7 +4819,7 @@ gfc_emit_parameter_debug_info (gfc_symbol *sym) TREE_TYPE (decl), sym->attr.dimension, false, false); - debug_hooks->global_decl (decl); + debug_hooks->early_global_decl (decl); } @@ -5841,9 +5884,33 @@ gfc_generate_function_code (gfc_namespace * ns) tmp = gfc_trans_code (ns->code); gfc_add_expr_to_block (&body, tmp); - if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node) + if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node + || (sym->result && sym->result != sym + && sym->result->ts.type == BT_DERIVED + && sym->result->ts.u.derived->attr.alloc_comp)) { + bool artificial_result_decl = false; tree result = get_proc_result (sym); + gfc_symbol *rsym = sym == sym->result ? sym : sym->result; + + /* Make sure that a function returning an object with + alloc/pointer_components always has a result, where at least + the allocatable/pointer components are set to zero. */ + if (result == NULL_TREE && sym->attr.function + && ((sym->result->ts.type == BT_DERIVED + && (sym->attr.allocatable + || sym->attr.pointer + || sym->result->ts.u.derived->attr.alloc_comp + || sym->result->ts.u.derived->attr.pointer_comp)) + || (sym->result->ts.type == BT_CLASS + && (CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.class_pointer + || CLASS_DATA (sym->result)->attr.alloc_comp + || CLASS_DATA (sym->result)->attr.pointer_comp)))) + { + artificial_result_decl = true; + result = gfc_get_fake_result_decl (sym, 0); + } if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer) { @@ -5863,16 +5930,30 @@ gfc_generate_function_code (gfc_namespace * ns) null_pointer_node)); } else if (sym->ts.type == BT_DERIVED - && sym->ts.u.derived->attr.alloc_comp && !sym->attr.allocatable) { - rank = sym->as ? sym->as->rank : 0; - tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank); - gfc_add_expr_to_block (&init, tmp); + gfc_expr *init_exp; + /* Arrays are not initialized using the default initializer of + their elements. Therefore only check if a default + initializer is available when the result is scalar. */ + init_exp = rsym->as ? NULL : gfc_default_initializer (&rsym->ts); + if (init_exp) + { + tmp = gfc_trans_structure_assign (result, init_exp, 0); + gfc_free_expr (init_exp); + gfc_add_expr_to_block (&init, tmp); + } + else if (rsym->ts.u.derived->attr.alloc_comp) + { + rank = rsym->as ? rsym->as->rank : 0; + tmp = gfc_nullify_alloc_comp (rsym->ts.u.derived, result, + rank); + gfc_prepend_expr_to_block (&body, tmp); + } } } - if (result == NULL_TREE) + if (result == NULL_TREE || artificial_result_decl) { /* TODO: move to the appropriate place in resolve.c. */ if (warn_return_type && sym == sym->result) @@ -5882,7 +5963,7 @@ gfc_generate_function_code (gfc_namespace * ns) if (warn_return_type) TREE_NO_WARNING(sym->backend_decl) = 1; } - else + if (result != NULL_TREE) gfc_add_expr_to_block (&body, gfc_generate_return ()); } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 88f1af80e01..89b4dfd3443 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -25,17 +25,9 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "gfortran.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "options.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" +#include "options.h" #include "fold-const.h" #include "stringpool.h" #include "diagnostic-core.h" /* For fatal_error. */ @@ -149,6 +141,11 @@ tree gfc_class_vptr_get (tree decl) { tree vptr; + /* For class arrays decl may be a temporary descriptor handle, the vptr is + then available through the saved descriptor. */ + if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); if (POINTER_TYPE_P (TREE_TYPE (decl))) decl = build_fold_indirect_ref_loc (input_location, decl); vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), @@ -163,6 +160,11 @@ tree gfc_class_len_get (tree decl) { tree len; + /* For class arrays decl may be a temporary descriptor handle, the len is + then available through the saved descriptor. */ + if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); if (POINTER_TYPE_P (TREE_TYPE (decl))) decl = build_fold_indirect_ref_loc (input_location, decl); len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), @@ -804,6 +806,16 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, gfc_add_modify (&parmse->pre, ctree, tmp); } + else if (class_ts.type == BT_CLASS + && class_ts.u.derived->components + && class_ts.u.derived->components->ts.u + .derived->attr.unlimited_polymorphic) + { + ctree = gfc_class_len_get (var); + gfc_add_modify (&parmse->pre, ctree, + fold_convert (TREE_TYPE (ctree), + integer_zero_node)); + } /* Pass the address of the class object. */ parmse->expr = gfc_build_addr_expr (NULL_TREE, var); } @@ -830,6 +842,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, tree tmp; tree vptr; tree cond = NULL_TREE; + tree slen = NULL_TREE; gfc_ref *ref; gfc_ref *class_ref; stmtblock_t block; @@ -921,7 +934,12 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, tmp = NULL_TREE; if (class_ref == NULL && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) - tmp = e->symtree->n.sym->backend_decl; + { + tmp = e->symtree->n.sym->backend_decl; + if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp)) + tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp); + slen = integer_zero_node; + } else { /* Remove everything after the last class reference, convert the @@ -933,6 +951,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, gfc_conv_expr (&tmpse, e); class_ref->next = ref; tmp = tmpse.expr; + slen = tmpse.string_length; } gcc_assert (tmp != NULL_TREE); @@ -951,11 +970,38 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, gfc_add_modify (&parmse->post, vptr, fold_convert (TREE_TYPE (vptr), ctree)); + /* For unlimited polymorphic objects also set the _len component. */ + if (class_ts.type == BT_CLASS + && class_ts.u.derived->components + && class_ts.u.derived->components->ts.u + .derived->attr.unlimited_polymorphic) + { + ctree = gfc_class_len_get (var); + if (UNLIMITED_POLY (e)) + tmp = gfc_class_len_get (tmp); + else if (e->ts.type == BT_CHARACTER) + { + gcc_assert (slen != NULL_TREE); + tmp = slen; + } + else + tmp = integer_zero_node; + gfc_add_modify (&parmse->pre, ctree, + fold_convert (TREE_TYPE (ctree), tmp)); + } + if (optional) { tree tmp2; cond = gfc_conv_expr_present (e->symtree->n.sym); + /* parmse->pre may contain some preparatory instructions for the + temporary array descriptor. Those may only be executed when the + optional argument is set, therefore add parmse->pre's instructions + to block, which is later guarded by an if (optional_arg_given). */ + gfc_add_block_to_block (&parmse->pre, &block); + block.head = parmse->pre.head; + parmse->pre.head = NULL_TREE; tmp = gfc_finish_block (&block); if (optional_alloc_ptr) @@ -1042,7 +1088,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) fcn_type = TREE_TYPE (TREE_TYPE (fcn)); if (from != NULL_TREE) - from_data = gfc_class_data_get (from); + from_data = gfc_class_data_get (from); else from_data = gfc_class_vtab_def_init_get (to); @@ -1099,7 +1145,8 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) gfc_init_block (&ifbody); gfc_add_block_to_block (&ifbody, &loop.pre); stdcopy = gfc_finish_block (&ifbody); - if (unlimited) + /* In initialization mode from_len is a constant zero. */ + if (unlimited && !integer_zerop (from_len)) { vec_safe_push (args, from_len); vec_safe_push (args, to_len); @@ -1141,7 +1188,8 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) vec_safe_push (args, to_data); stdcopy = build_call_vec (fcn_type, fcn, args); - if (unlimited) + /* In initialization mode from_len is a constant zero. */ + if (unlimited && !integer_zerop (from_len)) { vec_safe_push (args, from_len); vec_safe_push (args, to_len); @@ -1156,6 +1204,18 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) tmp = stdcopy; } + /* Only copy _def_init to to_data, when it is not a NULL-pointer. */ + if (from == NULL_TREE) + { + tree cond; + cond = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + from_data, null_pointer_node); + tmp = fold_build3_loc (input_location, COND_EXPR, + void_type_node, cond, + tmp, build_empty_stmt (input_location)); + } + return tmp; } @@ -1229,6 +1289,8 @@ gfc_trans_class_init_assign (gfc_code *code) been referenced. */ gfc_get_derived_type (rhs->ts.u.derived); gfc_add_def_init_component (rhs); + /* The _def_init is always scalar. */ + rhs->rank = 0; if (code->expr1->ts.type == BT_CLASS && CLASS_DATA (code->expr1)->attr.dimension) @@ -1402,7 +1464,6 @@ realloc_lhs_warning (bt type, bool array, locus *where) } -static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init); static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *, gfc_expr *); @@ -2203,6 +2264,16 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) field = f2; } + if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS + && strcmp ("_data", c->name) == 0) + { + /* Found a ref to the _data component. Store the associated ref to + the vptr in se->class_vptr. */ + se->class_vptr = gfc_class_vptr_get (decl); + } + else + se->class_vptr = NULL_TREE; + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE); @@ -2284,8 +2355,11 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) bool return_value; bool alternate_entry; bool entry_master; + bool is_classarray; + bool first_time = true; sym = expr->symtree->n.sym; + is_classarray = IS_CLASS_ARRAY (sym); ss = se->ss; if (ss != NULL) { @@ -2389,9 +2463,24 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) } else if (!sym->attr.value) { + /* Dereference temporaries for class array dummy arguments. */ + if (sym->attr.dummy && is_classarray + && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))) + { + if (!se->descriptor_only) + se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr); + + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); + } + /* Dereference non-character scalar dummy arguments. */ if (sym->attr.dummy && !sym->attr.dimension - && !(sym->attr.codimension && sym->attr.allocatable)) + && !(sym->attr.codimension && sym->attr.allocatable) + && (sym->ts.type != BT_CLASS + || (!CLASS_DATA (sym)->attr.dimension + && !(CLASS_DATA (sym)->attr.codimension + && CLASS_DATA (sym)->attr.allocatable)))) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); @@ -2403,11 +2492,12 @@ 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, non-class pointer variables. These must be dummies, results, or scalars. */ - if ((sym->attr.pointer || sym->attr.allocatable - || gfc_is_associate_pointer (sym) - || (sym->as && sym->as->type == AS_ASSUMED_RANK)) + if (!is_classarray + && (sym->attr.pointer || sym->attr.allocatable + || gfc_is_associate_pointer (sym) + || (sym->as && sym->as->type == AS_ASSUMED_RANK)) && (sym->attr.dummy || sym->attr.function || sym->attr.result @@ -2415,6 +2505,33 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) && (!sym->attr.codimension || !sym->attr.allocatable)))) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); + /* Now treat the class array pointer variables accordingly. */ + else if (sym->ts.type == BT_CLASS + && sym->attr.dummy + && (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.codimension) + && ((CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.class_pointer)) + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); + /* And the case where a non-dummy, non-result, non-function, + non-allotable and non-pointer classarray is present. This case was + previously covered by the first if, but with introducing the + condition !is_classarray there, that case has to be covered + explicitly. */ + else if (sym->ts.type == BT_CLASS + && !sym->attr.dummy + && !sym->attr.function + && !sym->attr.result + && (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.codimension) + && (sym->assoc + || !CLASS_DATA (sym)->attr.allocatable) + && !CLASS_DATA (sym)->attr.class_pointer) + se->expr = build_fold_indirect_ref_loc (input_location, + se->expr); } ref = expr->ref; @@ -2452,6 +2569,18 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) break; case REF_COMPONENT: + if (first_time && is_classarray && sym->attr.dummy + && se->descriptor_only + && !CLASS_DATA (sym)->attr.allocatable + && !CLASS_DATA (sym)->attr.class_pointer + && CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK + && strcmp ("_data", ref->u.c.component->name) == 0) + /* Skip the first ref of a _data component, because for class + arrays that one is already done by introducing a temporary + array descriptor. */ + break; + if (ref->u.c.sym->attr.extension) conv_parent_component_references (se, ref); @@ -2471,6 +2600,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) gcc_unreachable (); break; } + first_time = false; ref = ref->next; } /* Pointer assignment, allocation or pass by reference. Arrays are handled @@ -4398,6 +4528,62 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name) } +/* This function tells whether the middle-end representation of the expression + E given as input may point to data otherwise accessible through a variable + (sub-)reference. + It is assumed that the only expressions that may alias are variables, + and array constructors if ARRAY_MAY_ALIAS is true and some of its elements + may alias. + This function is used to decide whether freeing an expression's allocatable + components is safe or should be avoided. + + If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of + its elements are copied from a variable. This ARRAY_MAY_ALIAS trick + is necessary because for array constructors, aliasing depends on how + the array is used: + - If E is an array constructor used as argument to an elemental procedure, + the array, which is generated through shallow copy by the scalarizer, + is used directly and can alias the expressions it was copied from. + - If E is an array constructor used as argument to a non-elemental + procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate + the array as in the previous case, but then that array is used + to initialize a new descriptor through deep copy. There is no alias + possible in that case. + Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases + above. */ + +static bool +expr_may_alias_variables (gfc_expr *e, bool array_may_alias) +{ + gfc_constructor *c; + + if (e->expr_type == EXPR_VARIABLE) + return true; + else if (e->expr_type == EXPR_FUNCTION) + { + gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e); + + if ((proc_ifc->result->ts.type == BT_CLASS + && proc_ifc->result->ts.u.derived->attr.is_class + && CLASS_DATA (proc_ifc->result)->attr.class_pointer) + || proc_ifc->result->attr.pointer) + return true; + else + return false; + } + else if (e->expr_type != EXPR_ARRAY || !array_may_alias) + return false; + + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + if (c->expr + && expr_may_alias_variables (c->expr, array_may_alias)) + return true; + + return false; +} + + /* 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. @@ -4429,6 +4615,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, int has_alternate_specifier = 0; bool need_interface_mapping; bool callee_alloc; + bool ulim_copy; gfc_typespec ts; gfc_charlen cl; gfc_expr *e; @@ -4437,6 +4624,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; gfc_component *comp = NULL; int arglen; + unsigned int argc; arglist = NULL; retargs = NULL; @@ -4448,9 +4636,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, comp = gfc_get_proc_ptr_comp (expr); + bool elemental_proc = (comp + && comp->ts.interface + && comp->ts.interface->attr.elemental) + || (comp && comp->attr.elemental) + || sym->attr.elemental; + if (se->ss != NULL) { - if (!sym->attr.elemental && !(comp && comp->attr.elemental)) + if (!elemental_proc) { gcc_assert (se->ss->info->type == GFC_SS_FUNCTION); if (se->ss->info->useflags) @@ -4492,15 +4686,38 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } base_object = NULL_TREE; + /* For _vprt->_copy () routines no formal symbol is present. Nevertheless + is the third and fourth argument to such a function call a value + denoting the number of elements to copy (i.e., most of the time the + length of a deferred length string). */ + ulim_copy = formal == NULL && UNLIMITED_POLY (sym) + && strcmp ("_copy", comp->name) == 0; /* Evaluate the arguments. */ - for (arg = args; arg != NULL; - arg = arg->next, formal = formal ? formal->next : NULL) + for (arg = args, argc = 0; arg != NULL; + arg = arg->next, formal = formal ? formal->next : NULL, ++argc) { e = arg->expr; fsym = formal ? formal->sym : NULL; parm_kind = MISSING; + /* If the procedure requires an explicit interface, the actual + argument is passed according to the corresponding formal + argument. If the corresponding formal argument is a POINTER, + ALLOCATABLE or assumed shape, we do not use g77's calling + convention, and pass the address of the array descriptor + instead. Otherwise we use g77's calling convention, in other words + pass the array data pointer without descriptor. */ + bool nodesc_arg = fsym != NULL + && !(fsym->attr.pointer || fsym->attr.allocatable) + && fsym->as + && fsym->as->type != AS_ASSUMED_SHAPE + && fsym->as->type != AS_ASSUMED_RANK; + if (comp) + nodesc_arg = nodesc_arg || !comp->attr.always_explicit; + else + nodesc_arg = nodesc_arg || !sym->attr.always_explicit; + /* Class array expressions are sometimes coming completely unadorned with either arrayspec or _data component. Correct that here. OOP-TODO: Move this to the frontend. */ @@ -4597,7 +4814,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_init_se (&parmse, se); parm_kind = ELEMENTAL; - if (fsym && fsym->attr.value) + /* When no fsym is present, ulim_copy is set and this is a third or + fourth argument, use call-by-value instead of by reference to + hand the length properties to the copy routine (i.e., most of the + time this will be a call to a __copy_character_* routine where the + third and fourth arguments are the lengths of a deferred length + char array). */ + if ((fsym && fsym->attr.value) + || (ulim_copy && (argc == 2 || argc == 3))) gfc_conv_expr (&parmse, e); else gfc_conv_expr_reference (&parmse, e); @@ -5020,22 +5244,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } else { - /* If the procedure requires an explicit interface, the actual - argument is passed according to the corresponding formal - argument. If the corresponding formal argument is a POINTER, - ALLOCATABLE or assumed shape, we do not use g77's calling - convention, and pass the address of the array descriptor - instead. Otherwise we use g77's calling convention. */ - bool f; - f = (fsym != NULL) - && !(fsym->attr.pointer || fsym->attr.allocatable) - && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE - && fsym->as->type != AS_ASSUMED_RANK; - if (comp) - f = f || !comp->attr.always_explicit; - else - f = f || !sym->attr.always_explicit; - /* If the argument is a function call that may not create a temporary for the result, we have to check that we can do it, i.e. that there is no alias between this @@ -5080,7 +5288,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, array of derived types. In this case, the argument is converted to a temporary, which is passed and then written back after the procedure call. */ - gfc_conv_subref_array_arg (&parmse, e, f, + gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, fsym ? fsym->attr.intent : INTENT_INOUT, fsym && fsym->attr.pointer); else if (gfc_is_class_array_ref (e, NULL) @@ -5092,7 +5300,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, OOP-TODO: Insert code so that if the dynamic type is the same as the declared type, copy-in/copy-out does not occur. */ - gfc_conv_subref_array_arg (&parmse, e, f, + gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, fsym ? fsym->attr.intent : INTENT_INOUT, fsym && fsym->attr.pointer); @@ -5103,12 +5311,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, intent in. */ { e->must_finalize = 1; - gfc_conv_subref_array_arg (&parmse, e, f, + gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, INTENT_IN, fsym && fsym->attr.pointer); } else - gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL); + gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym, + sym->name, NULL); /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ @@ -5150,7 +5359,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, but do not always set fsym. */ if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional - && ((e->rank != 0 && sym->attr.elemental) + && ((e->rank != 0 && elemental_proc) || e->representation.length || e->ts.type == BT_CHARACTER || (e->rank != 0 && (fsym == NULL @@ -5185,16 +5394,30 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_add_block_to_block (&post, &parmse.post); /* Allocated allocatable components of derived types must be - deallocated for non-variable scalars. Non-variable arrays are - dealt with in trans-array.c(gfc_conv_array_parameter). */ + deallocated for non-variable scalars, array arguments to elemental + procedures, and array arguments with descriptor to non-elemental + procedures. As bounds information for descriptorless arrays is no + longer available here, they are dealt with in trans-array.c + (gfc_conv_array_parameter). */ if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS) && e->ts.u.derived->attr.alloc_comp - && !(e->symtree && e->symtree->n.sym->attr.pointer) - && (e->expr_type != EXPR_VARIABLE && !e->rank)) - { + && (e->rank == 0 || elemental_proc || !nodesc_arg) + && !expr_may_alias_variables (e, elemental_proc)) + { int parm_rank; - tmp = build_fold_indirect_ref_loc (input_location, - parmse.expr); + /* It is known the e returns a structure type with at least one + allocatable component. When e is a function, ensure that the + function is called once only by using a temporary variable. */ + if (!DECL_P (parmse.expr)) + parmse.expr = gfc_evaluate_now_loc (input_location, + parmse.expr, &se->pre); + + if (fsym && fsym->attr.value) + tmp = parmse.expr; + else + tmp = build_fold_indirect_ref_loc (input_location, + parmse.expr); + parm_rank = e->rank; switch (parm_kind) { @@ -5739,6 +5962,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, fntype = TREE_TYPE (TREE_TYPE (se->expr)); se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist); + /* Allocatable scalar function results must be freed and nullified + after use. This necessitates the creation of a temporary to + hold the result to prevent duplicate calls. */ + if (!byref && sym->ts.type != BT_CHARACTER + && sym->attr.allocatable && !sym->attr.dimension) + { + tmp = gfc_create_var (TREE_TYPE (se->expr), NULL); + gfc_add_modify (&se->pre, tmp, se->expr); + se->expr = tmp; + tmp = gfc_call_free (tmp); + gfc_add_expr_to_block (&post, tmp); + gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0)); + } + /* If we have a pointer function, but we don't want a pointer, e.g. something like x = f() @@ -6504,7 +6741,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_conv_expr (&rse, expr); - tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true); + tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, true, true); gfc_add_expr_to_block (&body, tmp); gcc_assert (rse.ss == gfc_ss_terminator); @@ -6563,13 +6800,13 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, { tmp = TREE_TYPE (dest); tmp = gfc_duplicate_allocatable (dest, se.expr, - tmp, expr->rank); + tmp, expr->rank, NULL_TREE); } } else tmp = gfc_duplicate_allocatable (dest, se.expr, TREE_TYPE(cm->backend_decl), - cm->as->rank); + cm->as->rank, NULL_TREE); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &se.post); @@ -6732,6 +6969,29 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block, TREE_TYPE (tmp), tmp, fold_convert (TREE_TYPE (tmp), size)); } + else if (cm->ts.type == BT_CLASS) + { + gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED); + if (expr2->ts.type == BT_DERIVED) + { + tmp = gfc_get_symbol_decl (expr2->ts.u.derived); + size = TYPE_SIZE_UNIT (tmp); + } + else + { + gfc_expr *e2vtab; + gfc_se se; + e2vtab = gfc_find_and_cut_at_last_class_ref (expr2); + gfc_add_vptr_component (e2vtab); + gfc_add_size_component (e2vtab); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, e2vtab); + gfc_add_block_to_block (block, &se.pre); + size = fold_convert (size_type_node, se.expr); + gfc_free_expr (e2vtab); + } + size_in_bytes = size; + } else { /* Otherwise use the length in bytes of the rhs. */ @@ -6859,7 +7119,8 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, gfc_add_expr_to_block (&block, tmp); } else if (init && (cm->attr.allocatable - || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable))) + || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable + && expr->ts.type != BT_CLASS))) { /* Take care about non-array allocatable components here. The alloc_* routine below is motivated by the alloc_scalar_allocatable_for_ @@ -6912,19 +7173,31 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, { if (expr->expr_type != EXPR_STRUCTURE) { + tree dealloc = NULL_TREE; gfc_init_se (&se, NULL); gfc_conv_expr (&se, expr); gfc_add_block_to_block (&block, &se.pre); + /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the + expression in a temporary variable and deallocate the allocatable + components. Then we can the copy the expression to the result. */ if (cm->ts.u.derived->attr.alloc_comp - && expr->expr_type == EXPR_VARIABLE) + && expr->expr_type != EXPR_VARIABLE) + { + se.expr = gfc_evaluate_now (se.expr, &block); + dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr, + expr->rank); + } + gfc_add_modify (&block, dest, + fold_convert (TREE_TYPE (dest), se.expr)); + if (cm->ts.u.derived->attr.alloc_comp + && expr->expr_type != EXPR_NULL) { tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, dest, expr->rank); gfc_add_expr_to_block (&block, tmp); + if (dealloc != NULL_TREE) + gfc_add_expr_to_block (&block, dealloc); } - else - gfc_add_modify (&block, dest, - fold_convert (TREE_TYPE (dest), se.expr)); gfc_add_block_to_block (&block, &se.post); } else @@ -6985,7 +7258,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, /* Assign a derived type constructor to a variable. */ -static tree +tree gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init) { gfc_constructor *c; @@ -7160,11 +7433,9 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr) ss_info = ss->info; /* Substitute a scalar expression evaluated outside the scalarization - loop. */ + loop. */ se->expr = ss_info->data.scalar.value; - /* If the reference can be NULL, the value field contains the reference, - not the value the reference points to (see gfc_add_loop_ss_code). */ - if (ss_info->can_be_null_ref) + if (gfc_scalar_elemental_arg_saved_as_reference (ss_info)) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); se->string_length = ss_info->string_length; @@ -7300,7 +7571,7 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION) gfc_conv_string_parameter (se); - else + else se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); return; @@ -7365,20 +7636,6 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) /* Take the address of that value. */ se->expr = gfc_build_addr_expr (NULL_TREE, var); - if (expr->ts.type == BT_DERIVED && expr->rank - && !gfc_is_finalizable (expr->ts.u.derived, NULL) - && expr->ts.u.derived->attr.alloc_comp - && expr->expr_type != EXPR_VARIABLE) - { - tree tmp; - - tmp = build_fold_indirect_ref_loc (input_location, se->expr); - tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank); - - /* The components shall be deallocated before - their containing entity. */ - gfc_prepend_expr_to_block (&se->post, tmp); - } } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index c4ccb7b77c8..967a74169c8 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -25,22 +25,12 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tm.h" /* For UNITS_PER_WORD. */ -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "wide-int.h" -#include "inchash.h" -#include "real.h" #include "tree.h" #include "fold-const.h" #include "stringpool.h" #include "tree-nested.h" #include "stor-layout.h" -#include "ggc.h" #include "gfortran.h" #include "diagnostic-core.h" /* For internal_error. */ #include "toplev.h" /* For rest_of_decl_compilation. */ @@ -5921,8 +5911,17 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) } else if (arg->ts.type == BT_CLASS) { - if (arg->rank) + /* For deferred length arrays, conv_expr_descriptor returns an + indirect_ref to the component. */ + if (arg->rank < 0 + || (arg->rank > 0 && !VAR_P (argse.expr) + && GFC_DECL_CLASS (TREE_OPERAND (argse.expr, 0)))) byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); + else if (arg->rank > 0) + /* The scalarizer added an additional temp. To get the class' vptr + one has to look at the original backend_decl. */ + byte_size = gfc_class_vtab_size_get ( + GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl)); else byte_size = gfc_class_vtab_size_get (argse.expr); } @@ -6053,7 +6052,11 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) gfc_conv_expr_descriptor (&argse, arg); if (arg->ts.type == BT_CLASS) { - tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); + if (arg->rank > 0) + tmp = gfc_class_vtab_size_get ( + GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl)); + else + tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); tmp = fold_convert (result_type, tmp); goto done; } @@ -7080,7 +7083,11 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) arg_expr = expr->value.function.actual->expr; if (arg_expr->rank == 0) - gfc_conv_expr_reference (se, arg_expr); + { + if (arg_expr->ts.type == BT_CLASS) + gfc_add_component_ref (arg_expr, "_data"); + gfc_conv_expr_reference (se, arg_expr); + } else gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL); se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr); @@ -8307,14 +8314,10 @@ walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr) if (tmp_ss->info->type != GFC_SS_SCALAR && tmp_ss->info->type != GFC_SS_REFERENCE) { - int tmp_dim; - gcc_assert (tmp_ss->dimen == 2); /* We just invert dimensions. */ - tmp_dim = tmp_ss->dim[0]; - tmp_ss->dim[0] = tmp_ss->dim[1]; - tmp_ss->dim[1] = tmp_dim; + std::swap (tmp_ss->dim[0], tmp_ss->dim[1]); } /* Stop when tmp_ss points to the last valid element of the chain... */ @@ -8801,7 +8804,7 @@ conv_co_collective (gfc_code *code) } opr_flags = build_int_cst (integer_type_node, opr_flag_int); gfc_conv_expr (&argse, opr_expr); - opr = gfc_build_addr_expr (NULL_TREE, argse.expr); + opr = argse.expr; fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr, opr_flags, image_index, stat, errmsg, strlen, errmsg_len); } diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index aa147066fd1..7afa726c961 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -22,21 +22,12 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "options.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" +#include "options.h" #include "fold-const.h" #include "stringpool.h" #include "stor-layout.h" -#include "ggc.h" #include "gfortran.h" #include "diagnostic-core.h" /* For internal_error. */ #include "trans.h" diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 9642a7d6b29..294b6ef731d 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -22,17 +22,9 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "options.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" +#include "options.h" #include "fold-const.h" #include "gimple-expr.h" #include "gimplify.h" /* For create_tmp_var_raw. */ @@ -391,9 +383,11 @@ gfc_walk_alloc_comps (tree decl, tree dest, tree var, if (GFC_DESCRIPTOR_TYPE_P (ftype) && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) tem = gfc_duplicate_allocatable (destf, declf, ftype, - GFC_TYPE_ARRAY_RANK (ftype)); + GFC_TYPE_ARRAY_RANK (ftype), + NULL_TREE); else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) - tem = gfc_duplicate_allocatable (destf, declf, ftype, 0); + tem = gfc_duplicate_allocatable (destf, declf, ftype, 0, + NULL_TREE); break; } if (tem) @@ -4114,6 +4108,7 @@ gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa) stmtblock_t block; gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; tree stmt, omp_clauses = NULL_TREE; + bool combined = true; gfc_start_block (&block); if (clausesa == NULL) @@ -4130,6 +4125,7 @@ gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa) case EXEC_OMP_TARGET_TEAMS: case EXEC_OMP_TEAMS: stmt = gfc_trans_omp_code (code->block->next, true); + combined = false; break; case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: case EXEC_OMP_TEAMS_DISTRIBUTE: @@ -4143,6 +4139,8 @@ gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa) } stmt = build2_loc (input_location, OMP_TEAMS, void_type_node, stmt, omp_clauses); + if (combined) + OMP_TEAMS_COMBINED (stmt) = 1; gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); } @@ -4163,9 +4161,14 @@ gfc_trans_omp_target (gfc_code *code) if (code->op == EXEC_OMP_TARGET) stmt = gfc_trans_omp_code (code->block->next, true); else - stmt = gfc_trans_omp_teams (code, clausesa); - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE); + { + pushlevel (); + stmt = gfc_trans_omp_teams (code, clausesa); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + } if (flag_openmp) stmt = build2_loc (input_location, OMP_TARGET, void_type_node, stmt, omp_clauses); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 91d2a85db68..6409f7f96e7 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -23,17 +23,9 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "options.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" +#include "options.h" #include "fold-const.h" #include "stringpool.h" #include "gfortran.h" @@ -45,7 +37,6 @@ 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 { @@ -1390,12 +1381,29 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_init_se (&se, NULL); se.descriptor_only = 1; - gfc_conv_expr (&se, e); + /* In a select type the (temporary) associate variable shall point to + a standard fortran array (lower bound == 1), but conv_expr () + just maps to the input array in the class object, whose lbound may + be arbitrary. conv_expr_descriptor solves this by inserting a + temporary array descriptor. */ + gfc_conv_expr_descriptor (&se, e); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) + || GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr))); gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl))); - gfc_add_modify (&se.pre, sym->backend_decl, se.expr); + if (GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr))) + { + if (INDIRECT_REF_P (se.expr)) + tmp = TREE_OPERAND (se.expr, 0); + else + tmp = se.expr; + + gfc_add_modify (&se.pre, sym->backend_decl, + gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp))); + } + else + gfc_add_modify (&se.pre, sym->backend_decl, se.expr); if (unlimited) { @@ -1406,7 +1414,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_get_dtype (TREE_TYPE (sym->backend_decl))); } - gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), + gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), gfc_finish_block (&se.post)); } @@ -1449,12 +1457,21 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) } if (need_len_assign) { - /* Get the _len comp from the target expr by stripping _data - from it and adding component-ref to _len. */ - tmp = gfc_class_len_get (TREE_OPERAND (target_expr, 0)); + if (e->symtree + && DECL_LANG_SPECIFIC (e->symtree->n.sym->backend_decl) + && GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl)) + /* Use the original class descriptor stored in the saved + descriptor to get the target_expr. */ + target_expr = + GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl); + else + /* Strip the _data component from the target_expr. */ + target_expr = TREE_OPERAND (target_expr, 0); + /* Add a reference to the _len comp to the target expr. */ + tmp = gfc_class_len_get (target_expr); /* Get the component-ref for the temp structure's _len comp. */ charlen = gfc_class_len_get (se.expr); - /* Add the assign to the beginning of the the block... */ + /* Add the assign to the beginning of the block... */ gfc_add_modify (&se.pre, charlen, fold_convert (TREE_TYPE (charlen), tmp)); /* and the oposite way at the end of the block, to hand changes @@ -5062,7 +5079,7 @@ tree gfc_trans_allocate (gfc_code * code) { gfc_alloc *al; - gfc_expr *expr; + gfc_expr *expr, *e3rhs = NULL; gfc_se se, se_sz; tree tmp; tree parm; @@ -5079,10 +5096,13 @@ gfc_trans_allocate (gfc_code * code) the trees may be the NULL_TREE indicating that this is not available for expr3's type. */ tree expr3, expr3_vptr, expr3_len, expr3_esize; + /* Classify what expr3 stores. */ + enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is; stmtblock_t block; stmtblock_t post; tree nelems; bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set; + gfc_symtree *newsym = NULL; if (!code->ext.alloc.list) return NULL_TREE; @@ -5090,6 +5110,7 @@ gfc_trans_allocate (gfc_code * code) stat = tmp = memsz = al_vptr = al_len = NULL_TREE; expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE; label_errmsg = label_finish = errmsg = errlen = NULL_TREE; + e3_is = E3_UNSET; gfc_init_block (&block); gfc_init_block (&post); @@ -5122,96 +5143,110 @@ gfc_trans_allocate (gfc_code * code) TREE_USED (label_finish) = 0; } - /* When an expr3 is present, try to evaluate it only once. In most - cases expr3 is invariant for all elements of the allocation list. - Only exceptions are arrays. Furthermore the standards prevent a - dependency of expr3 on the objects in the allocate list. Therefore - it is safe to pre-evaluate expr3 for complicated expressions, i.e. - everything not a variable or constant. When an array allocation - is wanted, then the following block nevertheless evaluates the - _vptr, _len and element_size for expr3. */ + /* When an expr3 is present evaluate it only once. The standards prevent a + dependency of expr3 on the objects in the allocate list. An expr3 can + be pre-evaluated in all cases. One just has to make sure, to use the + correct way, i.e., to get the descriptor or to get a reference + expression. */ if (code->expr3) { - bool vtab_needed = false; - /* expr3_tmp gets the tree when code->expr3.mold is set, i.e., - the expression is only needed to get the _vptr, _len a.s.o. */ - tree expr3_tmp = NULL_TREE; + bool vtab_needed = false, temp_var_needed = false; /* Figure whether we need the vtab from expr3. */ for (al = code->ext.alloc.list; !vtab_needed && al != NULL; al = al->next) vtab_needed = (al->expr->ts.type == BT_CLASS); - /* A array expr3 needs the scalarizer, therefore do not process it - here. */ - if (code->expr3->expr_type != EXPR_ARRAY - && (code->expr3->rank == 0 - || code->expr3->expr_type == EXPR_FUNCTION) - && (!code->expr3->symtree - || !code->expr3->symtree->n.sym->as) - && !gfc_is_class_array_ref (code->expr3, NULL)) - { - /* When expr3 is a variable, i.e., a very simple expression, + gfc_init_se (&se, NULL); + /* When expr3 is a variable, i.e., a very simple expression, then convert it once here. */ - if ((code->expr3->expr_type == EXPR_VARIABLE) - || code->expr3->expr_type == EXPR_CONSTANT) - { - if (!code->expr3->mold - || code->expr3->ts.type == BT_CHARACTER - || vtab_needed) - { - /* Convert expr3 to a tree. */ - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, code->expr3); - if (!code->expr3->mold) - expr3 = se.expr; - else - expr3_tmp = se.expr; - expr3_len = se.string_length; - gfc_add_block_to_block (&block, &se.pre); - gfc_add_block_to_block (&post, &se.post); - } - /* else expr3 = NULL_TREE set above. */ - } - else + if (code->expr3->expr_type == EXPR_VARIABLE + || code->expr3->expr_type == EXPR_ARRAY + || code->expr3->expr_type == EXPR_CONSTANT) + { + if (!code->expr3->mold + || code->expr3->ts.type == BT_CHARACTER + || vtab_needed + || code->ext.alloc.arr_spec_from_expr3) { - /* In all other cases evaluate the expr3 and create a - temporary. */ - gfc_init_se (&se, NULL); - if (code->expr3->rank != 0 - && code->expr3->expr_type == EXPR_FUNCTION - && code->expr3->value.function.isym) + /* Convert expr3 to a tree. For all "simple" expression just + get the descriptor or the reference, respectively, depending + on the rank of the expr. */ + if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0) gfc_conv_expr_descriptor (&se, code->expr3); else gfc_conv_expr_reference (&se, code->expr3); - if (code->expr3->ts.type == BT_CLASS) - gfc_conv_class_to_class (&se, code->expr3, - code->expr3->ts, - false, true, - false, false); - gfc_add_block_to_block (&block, &se.pre); - gfc_add_block_to_block (&post, &se.post); - /* Prevent aliasing, i.e., se.expr may be already a - variable declaration. */ - if (!VAR_P (se.expr)) - { - tmp = build_fold_indirect_ref_loc (input_location, - se.expr); - tmp = gfc_evaluate_now (tmp, &block); - } - else - tmp = se.expr; - if (!code->expr3->mold) - expr3 = tmp; - else - expr3_tmp = tmp; - /* When he length of a char array is easily available - here, fix it for future use. */ - if (se.string_length) - expr3_len = gfc_evaluate_now (se.string_length, &block); + /* Create a temp variable only for component refs to prevent + having to go through the full deref-chain each time and to + simplfy computation of array properties. */ + temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF; + } + } + else + { + /* In all other cases evaluate the expr3. */ + symbol_attribute attr; + /* Get the descriptor for all arrays, that are not allocatable or + pointer, because the latter are descriptors already. */ + attr = gfc_expr_attr (code->expr3); + if (code->expr3->rank != 0 && !attr.allocatable && !attr.pointer) + gfc_conv_expr_descriptor (&se, code->expr3); + else + gfc_conv_expr_reference (&se, code->expr3); + if (code->expr3->ts.type == BT_CLASS) + gfc_conv_class_to_class (&se, code->expr3, + code->expr3->ts, + false, true, + false, false); + temp_var_needed = !VAR_P (se.expr); + } + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post, &se.post); + /* Prevent aliasing, i.e., se.expr may be already a + variable declaration. */ + if (se.expr != NULL_TREE && temp_var_needed) + { + tree var; + tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ? + se.expr + : build_fold_indirect_ref_loc (input_location, se.expr); + /* We need a regular (non-UID) symbol here, therefore give a + prefix. */ + var = gfc_create_var (TREE_TYPE (tmp), "source"); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) + { + gfc_allocate_lang_decl (var); + GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr; + } + gfc_add_modify_loc (input_location, &block, var, tmp); + + /* Deallocate any allocatable components after all the allocations + and assignments of expr3 have been completed. */ + if (code->expr3->ts.type == BT_DERIVED + && code->expr3->rank == 0 + && code->expr3->ts.u.derived->attr.alloc_comp) + { + tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived, + var, 0); + gfc_add_expr_to_block (&post, tmp); } + + expr3 = var; + if (se.string_length) + /* Evaluate it assuming that it also is complicated like expr3. */ + expr3_len = gfc_evaluate_now (se.string_length, &block); + } + else + { + expr3 = se.expr; + expr3_len = se.string_length; } + /* Store what the expr3 is to be used for. */ + e3_is = expr3 != NULL_TREE ? + (code->ext.alloc.arr_spec_from_expr3 ? + E3_DESC + : (code->expr3->mold ? E3_MOLD : E3_SOURCE)) + : E3_UNSET; /* Figure how to get the _vtab entry. This also obtains the tree expression for accessing the _len component, because only @@ -5220,12 +5255,12 @@ gfc_trans_allocate (gfc_code * code) if (code->expr3->ts.type == BT_CLASS) { gfc_expr *rhs; - /* Polymorphic SOURCE: VPTR must be determined at run time. */ - if (expr3 != NULL_TREE && (VAR_P (expr3) || !code->expr3->ref)) + /* Polymorphic SOURCE: VPTR must be determined at run time. + expr3 may be a temporary array declaration, therefore check for + GFC_CLASS_TYPE_P before trying to get the _vptr component. */ + if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)) + && (VAR_P (expr3) || !code->expr3->ref)) tmp = gfc_class_vptr_get (expr3); - else if (expr3_tmp != NULL_TREE - && (VAR_P (expr3_tmp) ||!code->expr3->ref)) - tmp = gfc_class_vptr_get (expr3_tmp); else { rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); @@ -5245,9 +5280,7 @@ gfc_trans_allocate (gfc_code * code) { /* Same like for retrieving the _vptr. */ if (expr3 != NULL_TREE && !code->expr3->ref) - expr3_len = gfc_class_len_get (expr3); - else if (expr3_tmp != NULL_TREE && !code->expr3->ref) - expr3_len = gfc_class_len_get (expr3_tmp); + expr3_len = gfc_class_len_get (expr3); else { rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); @@ -5299,9 +5332,77 @@ gfc_trans_allocate (gfc_code * code) else expr3_esize = TYPE_SIZE_UNIT ( gfc_typenode_for_spec (&code->expr3->ts)); + + /* The routine gfc_trans_assignment () already implements all + techniques needed. Unfortunately we may have a temporary + variable for the source= expression here. When that is the + case convert this variable into a temporary gfc_expr of type + EXPR_VARIABLE and used it as rhs for the assignment. The + advantage is, that we get scalarizer support for free, + don't have to take care about scalar to array treatment and + will benefit of every enhancements gfc_trans_assignment () + gets. + No need to check whether e3_is is E3_UNSET, because that is + done by expr3 != NULL_TREE. */ + if (e3_is != E3_MOLD && expr3 != NULL_TREE + && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) + { + /* Build a temporary symtree and symbol. Do not add it to + the current namespace to prevent accidently modifying + a colliding symbol's as. */ + newsym = XCNEW (gfc_symtree); + /* The name of the symtree should be unique, because + gfc_create_var () took care about generating the + identifier. */ + newsym->name = gfc_get_string (IDENTIFIER_POINTER ( + DECL_NAME (expr3))); + newsym->n.sym = gfc_new_symbol (newsym->name, NULL); + /* The backend_decl is known. It is expr3, which is inserted + here. */ + newsym->n.sym->backend_decl = expr3; + e3rhs = gfc_get_expr (); + e3rhs->ts = code->expr3->ts; + e3rhs->rank = code->expr3->rank; + e3rhs->symtree = newsym; + /* Mark the symbol referenced or gfc_trans_assignment will + bug. */ + newsym->n.sym->attr.referenced = 1; + e3rhs->expr_type = EXPR_VARIABLE; + e3rhs->where = code->expr3->where; + /* Set the symbols type, upto it was BT_UNKNOWN. */ + newsym->n.sym->ts = e3rhs->ts; + /* Check whether the expr3 is array valued. */ + if (e3rhs->rank) + { + gfc_array_spec *arr; + arr = gfc_get_array_spec (); + arr->rank = e3rhs->rank; + arr->type = AS_DEFERRED; + /* Set the dimension and pointer attribute for arrays + to be on the safe side. */ + newsym->n.sym->attr.dimension = 1; + newsym->n.sym->attr.pointer = 1; + newsym->n.sym->as = arr; + gfc_add_full_array_ref (e3rhs, arr); + } + else if (POINTER_TYPE_P (TREE_TYPE (expr3))) + newsym->n.sym->attr.pointer = 1; + /* The string length is known to. Set it for char arrays. */ + if (e3rhs->ts.type == BT_CHARACTER) + newsym->n.sym->ts.u.cl->backend_decl = expr3_len; + gfc_commit_symbol (newsym->n.sym); + } + else + e3rhs = gfc_copy_expr (code->expr3); } gcc_assert (expr3_esize); expr3_esize = fold_convert (sizetype, expr3_esize); + if (e3_is == E3_MOLD) + { + /* The expr3 is no longer valid after this point. */ + expr3 = NULL_TREE; + e3_is = E3_UNSET; + } } else if (code->ext.alloc.ts.type != BT_UNKNOWN) { @@ -5401,7 +5502,11 @@ gfc_trans_allocate (gfc_code * code) else tmp = expr3_esize; if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, - label_finish, tmp, &nelems, code->expr3)) + label_finish, tmp, &nelems, + e3rhs ? e3rhs : code->expr3, + e3_is == E3_DESC ? expr3 : NULL_TREE, + code->expr3 != NULL && e3_is == E3_DESC + && code->expr3->expr_type == EXPR_ARRAY)) { /* A scalar or derived type. First compute the size to allocate. @@ -5478,7 +5583,7 @@ gfc_trans_allocate (gfc_code * code) memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); else /* Handle size computation of the type declared to alloc. */ - memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));; + memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); /* Allocate - for non-pointers with re-alloc checking. */ if (gfc_expr_attr (expr).allocatable) @@ -5602,40 +5707,32 @@ gfc_trans_allocate (gfc_code * code) } if (code->expr3 && !code->expr3->mold) { - /* Initialization via SOURCE block - (or static default initializer). */ - gfc_expr *rhs = gfc_copy_expr (code->expr3); + /* Initialization via SOURCE block (or static default initializer). + Classes need some special handling, so catch them first. */ if (expr3 != NULL_TREE && ((POINTER_TYPE_P (TREE_TYPE (expr3)) && TREE_CODE (expr3) != POINTER_PLUS_EXPR) - || VAR_P (expr3)) + || (VAR_P (expr3) && GFC_CLASS_TYPE_P ( + TREE_TYPE (expr3)))) && code->expr3->ts.type == BT_CLASS && (expr->ts.type == BT_CLASS || expr->ts.type == BT_DERIVED)) { + /* copy_class_to_class can be used for class arrays, too. + It just needs to be ensured, that the decl_saved_descriptor + has a way to get to the vptr. */ tree to; to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0); tmp = gfc_copy_class_to_class (expr3, to, nelems, upoly_expr); } - else if (code->expr3->ts.type == BT_CHARACTER) - { - tmp = INDIRECT_REF_P (se.expr) ? - se.expr : - build_fold_indirect_ref_loc (input_location, - se.expr); - gfc_trans_string_copy (&block, al_len, tmp, - code->expr3->ts.kind, - expr3_len, expr3, - code->expr3->ts.kind); - tmp = NULL_TREE; - } else if (al->expr->ts.type == BT_CLASS) { gfc_actual_arglist *actual, *last_arg; gfc_expr *ppc; gfc_code *ppc_code; gfc_ref *ref, *dataref; + gfc_expr *rhs = gfc_copy_expr (code->expr3); /* Do a polymorphic deep copy. */ actual = gfc_get_actual_arglist (); @@ -5657,30 +5754,14 @@ gfc_trans_allocate (gfc_code * code) if (dataref && dataref->u.c.component->as) { - int dim; - gfc_expr *temp; - gfc_ref *ref = dataref->next; - ref->u.ar.type = AR_SECTION; - /* We have to set up the array reference to give ranges - in all dimensions and ensure that the end and stride - are set so that the copy can be scalarized. */ - dim = 0; - for (; dim < dataref->u.c.component->as->rank; dim++) - { - ref->u.ar.dimen_type[dim] = DIMEN_RANGE; - if (ref->u.ar.end[dim] == NULL) - { - ref->u.ar.end[dim] = ref->u.ar.start[dim]; - temp = gfc_get_int_expr (gfc_default_integer_kind, - &al->expr->where, 1); - ref->u.ar.start[dim] = temp; - } - temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]), - gfc_copy_expr (ref->u.ar.start[dim])); - temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind, - &al->expr->where, 1), - temp); - } + gfc_array_spec *as = dataref->u.c.component->as; + gfc_free_ref_list (dataref->next); + dataref->next = NULL; + gfc_add_full_array_ref (last_arg->expr, as); + gfc_resolve_expr (last_arg->expr); + gcc_assert (last_arg->expr->ts.type == BT_CLASS + || last_arg->expr->ts.type == BT_DERIVED); + last_arg->expr->ts.type = BT_CLASS; } if (rhs->ts.type == BT_CLASS) { @@ -5732,8 +5813,8 @@ gfc_trans_allocate (gfc_code * code) gfc_add_len_component (last_arg->expr); } else if (code->expr3->ts.type == BT_CHARACTER) - last_arg->expr = - gfc_copy_expr (code->expr3->ts.u.cl->length); + last_arg->expr = + gfc_copy_expr (code->expr3->ts.u.cl->length); else gcc_unreachable (); @@ -5747,6 +5828,7 @@ gfc_trans_allocate (gfc_code * code) void_type_node, tmp, extcopy, stdcopy); } gfc_free_statements (ppc_code); + gfc_free_expr (rhs); } else { @@ -5755,14 +5837,13 @@ gfc_trans_allocate (gfc_code * code) int realloc_lhs = flag_realloc_lhs; flag_realloc_lhs = 0; tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), - rhs, false, false); + e3rhs, false, false); flag_realloc_lhs = realloc_lhs; } - gfc_free_expr (rhs); gfc_add_expr_to_block (&block, tmp); } else if (code->expr3 && code->expr3->mold - && code->expr3->ts.type == BT_CLASS) + && code->expr3->ts.type == BT_CLASS) { /* Since the _vptr has already been assigned to the allocate object, we can use gfc_copy_class_to_class in its @@ -5776,6 +5857,15 @@ gfc_trans_allocate (gfc_code * code) gfc_free_expr (expr); } // for-loop + if (e3rhs) + { + if (newsym) + { + gfc_free_symbol (newsym->n.sym); + XDELETE (newsym); + } + gfc_free_expr (e3rhs); + } /* STAT. */ if (code->expr1) { diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 0ad8ac20758..7f3f2619fdd 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -24,32 +24,14 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "tm.h" /* For INTMAX_TYPE, INT8_TYPE, INT16_TYPE, INT32_TYPE, - INT64_TYPE, INT_LEAST8_TYPE, INT_LEAST16_TYPE, - INT_LEAST32_TYPE, INT_LEAST64_TYPE, INT_FAST8_TYPE, - INT_FAST16_TYPE, INT_FAST32_TYPE, INT_FAST64_TYPE, - BOOL_TYPE_SIZE, BITS_PER_UNIT, POINTER_SIZE, - INT_TYPE_SIZE, CHAR_TYPE_SIZE, SHORT_TYPE_SIZE, - LONG_TYPE_SIZE, LONG_LONG_TYPE_SIZE, - FLOAT_TYPE_SIZE, DOUBLE_TYPE_SIZE and - LONG_DOUBLE_TYPE_SIZE. */ -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" +#include "tm.h" #include "alias.h" -#include "symtab.h" -#include "wide-int.h" -#include "inchash.h" -#include "real.h" #include "tree.h" #include "fold-const.h" #include "stor-layout.h" #include "stringpool.h" #include "langhooks.h" /* For iso-c-bindings.def. */ #include "target.h" -#include "ggc.h" #include "gfortran.h" #include "diagnostic-core.h" /* For fatal_error. */ #include "toplev.h" /* For rest_of_decl_compilation. */ @@ -438,10 +420,10 @@ gfc_init_kinds (void) /* Only let float, double, long double and __float128 go through. Runtime support for others is not provided, so they would be useless. */ - if (!targetm.libgcc_floating_mode_supported_p ((machine_mode) + if (!targetm.libgcc_floating_mode_supported_p ((machine_mode) mode)) - continue; - if (mode != TYPE_MODE (float_type_node) + continue; + if (mode != TYPE_MODE (float_type_node) && (mode != TYPE_MODE (double_type_node)) && (mode != TYPE_MODE (long_double_type_node)) #if defined(HAVE_TFmode) && defined(ENABLE_LIBQUADMATH_SUPPORT) @@ -587,7 +569,7 @@ gfc_init_kinds (void) gfc_fatal_error ("REAL(KIND=4) is not available for " "%<-freal-8-real-4%> option"); - gfc_default_double_kind = 4; + gfc_default_double_kind = 4; } else if (flag_real8_kind == 10 ) { @@ -595,7 +577,7 @@ gfc_init_kinds (void) gfc_fatal_error ("REAL(KIND=10) is not available for " "%<-freal-8-real-10%> option"); - gfc_default_double_kind = 10; + gfc_default_double_kind = 10; } else if (flag_real8_kind == 16 ) { @@ -603,7 +585,7 @@ gfc_init_kinds (void) gfc_fatal_error ("REAL(KIND=10) is not available for " "%<-freal-8-real-16%> option"); - gfc_default_double_kind = 16; + gfc_default_double_kind = 16; } else if (saw_r4 && saw_r8) gfc_default_double_kind = 8; @@ -1288,25 +1270,35 @@ gfc_get_element_type (tree type) int gfc_is_nodesc_array (gfc_symbol * sym) { - gcc_assert (sym->attr.dimension || sym->attr.codimension); + symbol_attribute *array_attr; + gfc_array_spec *as; + bool is_classarray = IS_CLASS_ARRAY (sym); + + array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; + as = is_classarray ? CLASS_DATA (sym)->as : sym->as; + + gcc_assert (array_attr->dimension || array_attr->codimension); /* We only want local arrays. */ - if (sym->attr.pointer || sym->attr.allocatable) + if ((sym->ts.type != BT_CLASS && sym->attr.pointer) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) + || array_attr->allocatable) return 0; /* We want a descriptor for associate-name arrays that do not have an - explicitly known shape already. */ - if (sym->assoc && sym->as->type != AS_EXPLICIT) + explicitly known shape already. */ + if (sym->assoc && as->type != AS_EXPLICIT) return 0; + /* The dummy is stored in sym and not in the component. */ if (sym->attr.dummy) - return sym->as->type != AS_ASSUMED_SHAPE - && sym->as->type != AS_ASSUMED_RANK; + return as->type != AS_ASSUMED_SHAPE + && as->type != AS_ASSUMED_RANK; if (sym->attr.result || sym->attr.function) return 0; - gcc_assert (sym->as->type == AS_EXPLICIT || sym->as->cp_was_assumed); + gcc_assert (as->type == AS_EXPLICIT || as->cp_was_assumed); return 1; } diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 549e921b3fb..aece77ab5cd 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -22,17 +22,9 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "gfortran.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" #include "alias.h" -#include "symtab.h" -#include "options.h" -#include "wide-int.h" -#include "inchash.h" #include "tree.h" +#include "options.h" #include "fold-const.h" #include "gimple-expr.h" /* For create_tmp_var_raw. */ #include "stringpool.h" @@ -321,7 +313,7 @@ gfc_build_addr_expr (tree type, tree t) /* Build an ARRAY_REF with its natural type. */ tree -gfc_build_array_ref (tree base, tree offset, tree decl) +gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) { tree type = TREE_TYPE (base); tree tmp; @@ -353,30 +345,47 @@ gfc_build_array_ref (tree base, tree offset, tree decl) /* If the array reference is to a pointer, whose target contains a subreference, use the span that is stored with the backend decl and reference the element with pointer arithmetic. */ - if (decl && (TREE_CODE (decl) == FIELD_DECL - || TREE_CODE (decl) == VAR_DECL - || TREE_CODE (decl) == PARM_DECL) - && ((GFC_DECL_SUBREF_ARRAY_P (decl) - && !integer_zerop (GFC_DECL_SPAN(decl))) + if ((decl && (TREE_CODE (decl) == FIELD_DECL + || TREE_CODE (decl) == VAR_DECL + || TREE_CODE (decl) == PARM_DECL) + && ((GFC_DECL_SUBREF_ARRAY_P (decl) + && !integer_zerop (GFC_DECL_SPAN (decl))) || GFC_DECL_CLASS (decl))) + || vptr) { - if (GFC_DECL_CLASS (decl)) + if (decl) { - /* Allow for dummy arguments and other good things. */ - if (POINTER_TYPE_P (TREE_TYPE (decl))) - decl = build_fold_indirect_ref_loc (input_location, decl); - - /* Check if '_data' is an array descriptor. If it is not, - the array must be one of the components of the class object, - so return a normal array reference. */ - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl)))) - return build4_loc (input_location, ARRAY_REF, type, base, - offset, NULL_TREE, NULL_TREE); - - span = gfc_class_vtab_size_get (decl); + if (GFC_DECL_CLASS (decl)) + { + /* When a temporary is in place for the class array, then the + original class' declaration is stored in the saved + descriptor. */ + if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + else + { + /* Allow for dummy arguments and other good things. */ + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + + /* Check if '_data' is an array descriptor. If it is not, + the array must be one of the components of the class + object, so return a normal array reference. */ + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE ( + gfc_class_data_get (decl)))) + return build4_loc (input_location, ARRAY_REF, type, base, + offset, NULL_TREE, NULL_TREE); + } + + span = gfc_class_vtab_size_get (decl); + } + else if (GFC_DECL_SUBREF_ARRAY_P (decl)) + span = GFC_DECL_SPAN (decl); + else + gcc_unreachable (); } - else if (GFC_DECL_SUBREF_ARRAY_P (decl)) - span = GFC_DECL_SPAN(decl); + else if (vptr) + span = gfc_vptr_size_get (vptr); else gcc_unreachable (); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 199835861cd..f7cf5f016fe 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -49,6 +49,10 @@ typedef struct gfc_se /* The length of a character string value. */ tree string_length; + /* When expr is a reference to a class object, store its vptr access + here. */ + tree class_vptr; + /* If set gfc_conv_variable will return an expression for the array descriptor. When set, want_pointer should also be set. If not set scalarizing variables will be substituted. */ @@ -202,6 +206,9 @@ typedef struct gfc_ss_info /* If type is GFC_SS_SCALAR or GFC_SS_REFERENCE. */ struct { + /* If the scalar is passed as actual argument to an (elemental) procedure, + this is the symbol of the corresponding dummy argument. */ + gfc_symbol *dummy_arg; tree value; } scalar; @@ -528,7 +535,7 @@ tree gfc_get_function_decl (gfc_symbol *); tree gfc_build_addr_expr (tree, tree); /* Build an ARRAY_REF. */ -tree gfc_build_array_ref (tree, tree, tree); +tree gfc_build_array_ref (tree, tree, tree, tree vptr = NULL_TREE); /* Creates a label. Decl is artificial if label_id == NULL_TREE. */ tree gfc_build_label_decl (tree); @@ -591,7 +598,7 @@ void gfc_generate_module_vars (gfc_namespace *); /* Get the appropriate return statement for a procedure. */ tree gfc_generate_return (void); -struct module_decl_hasher : ggc_hasher<tree_node *> +struct module_decl_hasher : ggc_ptr_hash<tree_node> { typedef const char *compare_type; @@ -662,6 +669,9 @@ tree gfc_deallocate_scalar_with_status (tree, tree, bool, gfc_expr*, gfc_typespe /* Generate code to call realloc(). */ tree gfc_call_realloc (stmtblock_t *, tree, tree); +/* Assign a derived type constructor to a variable. */ +tree gfc_trans_structure_assign (tree, gfc_expr *, bool); + /* Generate code for an assignment, includes scalarization. */ tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool); |